Annotation of /renderer/pack.lAnnotation of /renderer/pack.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | (declare (err:end-of-file) special) |
| 2 : | ; | ||
| 3 : | (defun loadprimfile (primfile (printp)) | ||
| 4 : | (let ((si (inopen (stream primfile))) | ||
| 5 : | (l nil) | ||
| 6 : | (err:end-of-file '(lambda (x (y))(throw 'eof)))) | ||
| 7 : | (catch 'eof | ||
| 8 : | (loop (setq l (read si)) | ||
| 9 : | ; (print l) | ||
| 10 : | (match l | ||
| 11 : | (('setq sym body) | ||
| 12 : | (cond ((and (consp body) | ||
| 13 : | (eq 'quote (car body)) | ||
| 14 : | (consp (cdr body))) | ||
| 15 : | ; (print sym) | ||
| 16 : | (set sym (packprim (cadr body)))))) | ||
| 17 : | (default | ||
| 18 : | ; (print default) | ||
| 19 : | (eval default))))))) | ||
| 20 : | ; | ||
| 21 : | (defun packprimfile (primfile packfile) | ||
| 22 : | (let ((si (inopen (stream primfile))) | ||
| 23 : | (standard-output (outopen (stream packfile))) | ||
| 24 : | (printlevel 0)(printlength 0) | ||
| 25 : | (l nil) | ||
| 26 : | (err:end-of-file '(lambda (x (y))(throw 'eof)))) | ||
| 27 : | (catch 'eof | ||
| 28 : | (loop (setq l (read si)) | ||
| 29 : | ; (print l) | ||
| 30 : | (match l | ||
| 31 : | (('setq sym body) | ||
| 32 : | (cond ((and (consp body) | ||
| 33 : | (eq 'quote (car body)) | ||
| 34 : | (consp (cdr body))) | ||
| 35 : | ; (print sym) | ||
| 36 : | ; (set sym (packprim (cadr body))) | ||
| 37 : | (prind `(setq ,sym ',(packprim (cadr body)))) | ||
| 38 : | ))) | ||
| 39 : | (default | ||
| 40 : | ; (print default) | ||
| 41 : | (prind default))))))) | ||
| 42 : | |||
| 43 : | ; | ||
| 44 : | (defun packprim (prim) | ||
| 45 : | (match prim | ||
| 46 : | ((points lines . alist) | ||
| 47 : | (lets ((packpoints (packpoints points)) | ||
| 48 : | (packlines (packlines lines))) | ||
| 49 : | (cond ((and (stringp packpoints)(stringp packlines)) | ||
| 50 : | (cond (alist `(,(string-append packpoints packlines) .,alist)) | ||
| 51 : | (t (string-append packpoints packlines)))) | ||
| 52 : | (t `(,packpoints ,packlines .,alist))))) | ||
| 53 : | (default default))) | ||
| 54 : | ; | ||
| 55 : | (defun unpackprim (packprim) | ||
| 56 : | (cond ((stringp packprim) | ||
| 57 : | (lets ((npoints (sref packprim 0))) | ||
| 58 : | `(,(unpackpoints (substring packprim 0 (+ 1 (* npoints 3)))) | ||
| 59 : | ,(unpacklines (substring packprim (+ 1 (* npoints 3))))))) | ||
| 60 : | ((null (cdr packprim))packprim) | ||
| 61 : | ((and (stringp (car packprim)) | ||
| 62 : | (> (string-length (car packprim)) | ||
| 63 : | (+ 1 (* 3 (sref (car packprim) 0))))) | ||
| 64 : | (lets ((str (car packprim)) | ||
| 65 : | (npoints (sref str 0))) | ||
| 66 : | `(,(unpackpoints (substring str 0 (+ 1 (* npoints 3)))) | ||
| 67 : | ,(unpacklines (substring str (+ 1 (* npoints 3)))) | ||
| 68 : | .,(cdr packprim)))) | ||
| 69 : | (t | ||
| 70 : | `(,(unpackpoints (car packprim)) | ||
| 71 : | ,(unpacklines (cadr packprim)) | ||
| 72 : | .,(cddr packprim))))) | ||
| 73 : | ; | ||
| 74 : | (defun packpoints (points) | ||
| 75 : | (do ((l points (cdr l)) | ||
| 76 : | (npoints 0 (1+ npoints)) | ||
| 77 : | (ret "")) | ||
| 78 : | ((atom l) | ||
| 79 : | (string-append (string npoints) ret)) | ||
| 80 : | (match (car l) | ||
| 81 : | ((x y) | ||
| 82 : | (setq ret (string-append ret (pack3 x y)))) | ||
| 83 : | ((x y ('link-ok 't)) | ||
| 84 : | (setq ret (string-append ret (pack3 x y)))) | ||
| 85 : | (default (exit points))))) | ||
| 86 : | ; | ||
| 87 : | (defun unpackpoints (packpoints) | ||
| 88 : | (cond ((stringp packpoints) | ||
| 89 : | (lets ((npoints (sref packpoints 0))) | ||
| 90 : | (do ((i 0 (1+ i)) | ||
| 91 : | (ret nil)) | ||
| 92 : | ((>= i npoints) | ||
| 93 : | (nreverse ret)) | ||
| 94 : | (push | ||
| 95 : | (unpack3 (substring packpoints (+ 1 (* i 3)) (+ 4 (* i 3)))) | ||
| 96 : | ret)))) | ||
| 97 : | (t packpoints))) | ||
| 98 : | ; | ||
| 99 : | (defun pack3 (x y) | ||
| 100 : | (string-append (string (logor (logand 240 (logshift x -4)) | ||
| 101 : | (logand 15 (logshift y -8)))) | ||
| 102 : | (string (logand 255 x)) | ||
| 103 : | (string (logand 255 y)))) | ||
| 104 : | (defun unpack3 (str) | ||
| 105 : | (lets ((hi (sref str 0)) | ||
| 106 : | (x (+ (logshift (logand 240 hi) 4)(sref str 1))) | ||
| 107 : | (y (+ (logshift (logand 15 hi) 8)(sref str 2)))) | ||
| 108 : | `(,x ,y))) | ||
| 109 : | ; | ||
| 110 : | (declare (elementtype elementtypelen) special) | ||
| 111 : | (setq elementtype '(ten tate yoko migiue hidari tatehidari migi kozato tatehane tsukurihane sanzui kokoro tasuki magaritate kagi shin-nyuu hira0 hira1 hira2 hira3)) | ||
| 112 : | ; | ||
| 113 : | (setq elementtypelen (length elementtype)) | ||
| 114 : | ; | ||
| 115 : | (defun type2num (type) | ||
| 116 : | (- elementtypelen (length (memq type elementtype)))) | ||
| 117 : | ; | ||
| 118 : | (defun num2type (num) | ||
| 119 : | (nth num elementtype)) | ||
| 120 : | ; | ||
| 121 : | (defun numlist2str (points) | ||
| 122 : | (do ((l points (cdr l)) | ||
| 123 : | (ret "")) | ||
| 124 : | ((atom l)ret) | ||
| 125 : | (setq ret (string-append ret (string (car l)))))) | ||
| 126 : | ; | ||
| 127 : | (defun str2numlist (str) | ||
| 128 : | (let ((len (string-length str))) | ||
| 129 : | (do ((i 0 (1+ i)) | ||
| 130 : | (ret nil)) | ||
| 131 : | ((>= i len) | ||
| 132 : | (nreverse ret)) | ||
| 133 : | (push (sref str i) ret)))) | ||
| 134 : | ; | ||
| 135 : | (defun packlines (lines) | ||
| 136 : | (do ((l lines (cdr l)) | ||
| 137 : | (laststr "") | ||
| 138 : | (ret nil)) | ||
| 139 : | ((atom l) | ||
| 140 : | (cond (ret | ||
| 141 : | (cond ((0< (string-length laststr)) | ||
| 142 : | (push laststr ret))) | ||
| 143 : | (nreverse ret)) | ||
| 144 : | (t laststr))) | ||
| 145 : | (match (car l) | ||
| 146 : | ((type points) | ||
| 147 : | (cond ((memq type elementtype) | ||
| 148 : | (setq laststr | ||
| 149 : | (string-append | ||
| 150 : | laststr | ||
| 151 : | (string (type2num type)) | ||
| 152 : | (string (length points)) | ||
| 153 : | (string 0) | ||
| 154 : | (numlist2str points)))) | ||
| 155 : | (t | ||
| 156 : | (cond ((0< (string-length laststr)) | ||
| 157 : | (push laststr ret))) | ||
| 158 : | (push (car l) ret) | ||
| 159 : | (setq laststr "")))) | ||
| 160 : | ((type points ('link . linkpoints)) | ||
| 161 : | (cond ((memq type elementtype) | ||
| 162 : | (setq laststr | ||
| 163 : | (string-append | ||
| 164 : | laststr | ||
| 165 : | (string (type2num type)) | ||
| 166 : | (string (length points)) | ||
| 167 : | (string (length linkpoints)) | ||
| 168 : | (numlist2str points) | ||
| 169 : | (numlist2str linkpoints)))) | ||
| 170 : | (t | ||
| 171 : | (cond ((0< (string-length laststr)) | ||
| 172 : | (push laststr ret))) | ||
| 173 : | (push (car l) ret) | ||
| 174 : | (setq laststr "")))) | ||
| 175 : | (default | ||
| 176 : | (cond ((0< (string-length laststr)) | ||
| 177 : | (push laststr ret))) | ||
| 178 : | (push default ret))))) | ||
| 179 : | ; | ||
| 180 : | (defun unpacklines (packlines) | ||
| 181 : | (cond ((stringp packlines) | ||
| 182 : | (unpacklinessub packlines)) | ||
| 183 : | ((consp packlines) | ||
| 184 : | (do ((l packlines (cdr l)) | ||
| 185 : | (ret nil)) | ||
| 186 : | ((atom l)ret) | ||
| 187 : | (cond ((stringp (car l)) | ||
| 188 : | (setq ret (append ret (unpacklinessub (car l))))) | ||
| 189 : | (t (setq ret (append ret (ncons (car l)))))))))) | ||
| 190 : | ; | ||
| 191 : | (defun unpacklinessub (packlines) | ||
| 192 : | (lets ((len (string-length packlines))) | ||
| 193 : | (do ((offset 0) | ||
| 194 : | (ret nil) | ||
| 195 : | (type nil) | ||
| 196 : | (points)(linkpoints) | ||
| 197 : | (npoints nil) | ||
| 198 : | (linknpoints nil)) | ||
| 199 : | ((>= offset len)(nreverse ret)) | ||
| 200 : | (setq type (num2type (sref packlines offset))) | ||
| 201 : | (setq npoints (sref packlines (1+ offset))) | ||
| 202 : | (setq linknpoints (sref packlines (+ offset 2))) | ||
| 203 : | (setq points (str2numlist (substring packlines (+ 3 offset) | ||
| 204 : | (+ 3 offset npoints)))) | ||
| 205 : | (setq linkpoints | ||
| 206 : | (str2numlist (substring packlines (+ 3 offset npoints) | ||
| 207 : | (+ 3 offset npoints linknpoints)))) | ||
| 208 : | (cond (linkpoints | ||
| 209 : | (push (list type points (cons 'link linkpoints)) ret)) | ||
| 210 : | (t | ||
| 211 : | (push (list type points) ret))) | ||
| 212 : | (setq offset (+ offset 3 npoints linknpoints))))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |