View of /renderer/pack.l

Parent Directory

Revision Log

*** empty log message ***

(declare (err:end-of-file) special)
;
(defun loadprimfile (primfile (printp))
  (let ((si (inopen (stream primfile)))
	(l nil)
	(err:end-of-file '(lambda (x (y))(throw 'eof))))
    (catch 'eof
      (loop (setq l (read si))
;	    (print l)
	    (match l
	      (('setq sym body)
	       (cond ((and (consp body)
			   (eq 'quote (car body))
			   (consp (cdr body)))
;		      (print sym)
		      (set sym (packprim (cadr body))))))
	      (default 
;		(print default)
		(eval default)))))))
;
(defun packprimfile (primfile packfile)
  (let ((si (inopen (stream primfile)))
	(standard-output (outopen (stream packfile)))
	(printlevel 0)(printlength 0)
	(l nil)
	(err:end-of-file '(lambda (x (y))(throw 'eof))))
    (catch 'eof
      (loop (setq l (read si))
;	    (print l)
	    (match l
	      (('setq sym body)
	       (cond ((and (consp body)
			   (eq 'quote (car body))
			   (consp (cdr body)))
;		      (print sym)
;		      (set sym (packprim (cadr body)))
		      (prind `(setq ,sym ',(packprim (cadr body))))
		      )))
	      (default 
;		(print default)
		(prind default)))))))
			   
;
(defun packprim (prim)
  (match prim
    ((points lines . alist)
     (lets ((packpoints (packpoints points))
	    (packlines (packlines lines)))
       (cond ((and (stringp packpoints)(stringp packlines))
	      (cond (alist `(,(string-append packpoints packlines) .,alist))
		    (t (string-append packpoints packlines))))
	     (t `(,packpoints ,packlines .,alist)))))
    (default default)))
;
(defun unpackprim (packprim)
  (cond ((stringp packprim)
	 (lets ((npoints (sref packprim 0)))
		`(,(unpackpoints (substring packprim 0 (+ 1 (* npoints 3))))
		  ,(unpacklines (substring packprim (+ 1 (* npoints 3)))))))
	((null (cdr packprim))packprim)
	((and (stringp (car packprim))
	      (> (string-length (car packprim))
		 (+ 1 (* 3 (sref (car packprim) 0)))))
	 (lets ((str (car packprim))
		(npoints (sref str 0)))
	   `(,(unpackpoints (substring str 0 (+ 1 (* npoints 3))))
	     ,(unpacklines (substring str (+ 1 (* npoints 3))))
	     .,(cdr packprim))))
	(t
	 `(,(unpackpoints (car packprim))
	   ,(unpacklines (cadr packprim))
	   .,(cddr packprim)))))
;
(defun packpoints (points)
  (do ((l points (cdr l))
       (npoints 0 (1+ npoints))
       (ret ""))
    ((atom l)
     (string-append (string npoints) ret))
    (match (car l)
      ((x y)
       (setq ret (string-append ret (pack3 x y))))
      ((x y ('link-ok 't))
       (setq ret (string-append ret (pack3 x y))))
      (default (exit points)))))
;
(defun unpackpoints (packpoints)
  (cond ((stringp packpoints)
	 (lets ((npoints (sref packpoints 0)))
	   (do ((i 0 (1+ i))
		(ret nil))
	     ((>= i npoints)
	      (nreverse ret))
	     (push 
	      (unpack3 (substring packpoints (+ 1 (* i 3)) (+ 4 (* i 3)))) 
	      ret))))
	(t packpoints)))
;
(defun pack3 (x y)
  (string-append (string (logor (logand 240 (logshift x -4))
				(logand 15 (logshift y -8))))
		 (string (logand 255 x))
		 (string (logand 255 y))))
(defun unpack3 (str)
  (lets ((hi (sref str 0))
	 (x (+ (logshift (logand 240 hi) 4)(sref str 1)))
	 (y (+ (logshift (logand 15 hi) 8)(sref str 2))))
    `(,x ,y)))
;
(declare (elementtype elementtypelen) special)
(setq elementtype '(ten tate yoko migiue hidari tatehidari migi kozato tatehane tsukurihane sanzui kokoro tasuki magaritate kagi shin-nyuu hira0 hira1 hira2 hira3))
;
(setq elementtypelen (length elementtype))
;
(defun type2num (type)
  (- elementtypelen (length (memq type elementtype))))
;
(defun num2type (num)
  (nth num elementtype))
;
(defun numlist2str (points)
  (do ((l points (cdr l))
       (ret ""))
    ((atom l)ret)
    (setq ret (string-append ret (string (car l))))))
;
(defun str2numlist (str)
  (let ((len (string-length str)))
    (do ((i 0 (1+ i))
	 (ret nil))
      ((>= i len)
       (nreverse ret))
      (push (sref str i) ret))))
;
(defun packlines (lines)
  (do ((l lines (cdr l))
       (laststr "")
       (ret nil))
    ((atom l)
     (cond (ret
	    (cond ((0< (string-length laststr)) 
		   (push laststr ret)))
	    (nreverse ret))
	   (t laststr)))
    (match (car l)
      ((type points)
       (cond ((memq type elementtype)
	      (setq laststr
		    (string-append
		     laststr
		     (string (type2num type))
		     (string (length points))
		     (string 0)
		     (numlist2str points))))
	     (t 
	      (cond ((0< (string-length laststr))
		     (push laststr ret)))
	      (push (car l) ret)
	      (setq laststr ""))))
      ((type points ('link . linkpoints))
       (cond ((memq type elementtype)
	      (setq laststr
		    (string-append
		     laststr
		     (string (type2num type))
		     (string (length points))
		     (string (length linkpoints))
		     (numlist2str points)
		     (numlist2str linkpoints))))
	     (t 
	      (cond ((0< (string-length laststr))
		     (push laststr ret)))
	      (push (car l) ret)
	      (setq laststr ""))))
      (default
	(cond ((0< (string-length laststr))
	       (push laststr ret)))
	(push default ret)))))
;
(defun unpacklines (packlines)
  (cond ((stringp packlines)
	 (unpacklinessub packlines))
	((consp packlines)
	 (do ((l packlines (cdr l))
	      (ret nil))
	   ((atom l)ret)
	   (cond ((stringp (car l))
		  (setq ret (append ret (unpacklinessub (car l)))))
		 (t (setq ret (append ret (ncons (car l))))))))))
;
(defun unpacklinessub (packlines)
  (lets ((len (string-length packlines)))
    (do ((offset 0)
	 (ret nil)
	 (type nil)
	 (points)(linkpoints)
	 (npoints nil)
	 (linknpoints nil))
      ((>= offset len)(nreverse ret))
      (setq type (num2type (sref packlines offset)))
      (setq npoints (sref packlines (1+ offset)))
      (setq linknpoints (sref packlines (+ offset 2)))
      (setq points (str2numlist (substring packlines (+ 3 offset)
					   (+ 3 offset npoints))))
      (setq linkpoints 
	    (str2numlist (substring packlines (+ 3 offset npoints)
				    (+ 3 offset npoints linknpoints))))
      (cond (linkpoints
	     (push (list type points (cons 'link linkpoints)) ret))
	    (t 
	     (push (list type points) ret)))
      (setq offset (+ offset 3 npoints linknpoints)))))