Adding blender exporter
[lodematron.git] / utils.lisp
blob7dc192460a0f0d766f20a8294eb0677de944568f
2 (in-package :lodematron)
4 ;; utils used throughout the code
7 (defmacro with-gensyms ((&rest names) &body forms)
8 "Create hygenic tempoary variables for macros"
9 `(let ,(loop for n in names collect `(,n (gensym)))
10 ,@forms))
12 (defmacro once-only ((&rest names) &body body)
13 "Evaluate form once only and assign to temp var for macro body"
14 (let ((gensyms (loop for n in names collect (gensym))))
15 `(let (,@(loop for g in gensyms collect `(,g (gensym))))
16 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
17 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
18 ,@body)))))
20 (defmacro destructure-bits (bits vals &body forms)
21 "Destructure a numeric variable into individual bits"
22 (once-only (bits)
23 `(let
24 ,(loop
25 for val in vals
26 for mask = 1 then (ash mask 1)
27 collect `(,val (logandc2 ,bits ,mask)))
28 (declare (ignorable ,@vals))
29 ,@forms)))
32 (defun make-extensible-string (dimensions &key (initial-element #\Space))
33 "Create an ajustable string"
34 (make-array dimensions
35 :element-type 'character
36 :initial-element initial-element
37 :adjustable t
38 :fill-pointer dimensions))
40 (defmacro indefinitely ((var form) &body body)
41 "Expand to a form that repeatedly binds var to form and evaluates body until
42 something goes wrong (like a condition being signalled)"
43 `(do ((,var ,form ,form))
44 (nil)
45 ,@body))
48 (defun extend-string (elements string)
49 "Add the elements to the end of the extensitble string."
50 (assert (adjustable-array-p string))
51 (labels
52 ((extend-string-with-string (chars string)
53 (iterate
54 (for char in-vector chars)
55 (vector-push-extend char string))
56 string))
57 (typecase elements
58 (character (vector-push-extend elements string))
59 (symbol (extend-string-with-string (string elements) string))
60 (string (extend-string-with-string elements string))
61 (number (extend-string-with-string (format nil "~D" elements) string))
62 (list (mapcar #'(lambda (x)
63 (extend-string x string))
64 elements))))
65 string)
67 (defun collapse-string (stringlist)
68 "Given a list of strings collapse it to a single string."
69 (let ((result (make-extensible-string 0)))
70 (iterate
71 (for string in stringlist)
72 (iterate
73 (for char in-vector string)
74 (vector-push-extend char result)))
75 result))
78 (defmacro formatting (stream initial-string &rest args)
79 "Format replacement using keywords rather than a control string."
80 (labels
81 ((add-numeric-control (control-char control-keys format-string)
82 (extend-string #\~ format-string)
83 (destructuring-bind
84 (&key width fillchar form)
85 control-keys
86 (declare (ignore form))
87 (when width
88 (extend-string width format-string)
89 (when fillchar
90 (extend-string #\, format-string)
91 (extend-string #\' format-string)
92 (extend-string fillchar format-string)))
93 (extend-string control-char format-string)))
94 (process-control-item (control)
95 (let ((format-string (make-extensible-string 0)))
96 (typecase control
97 (string
98 (extend-string control format-string))
99 ;; handle simle forms
100 (symbol
101 (case control
102 (:tab (extend-string "~T" format-string))
103 (:binary (extend-string "~B" format-string))
104 (:octal (extend-string "~O" format-string))
105 (:decimal (extend-string "~D" format-string))
106 (:hex (extend-string "~X" format-string))
107 (:newline (extend-string "~%" format-string))
108 (:freshline (extend-string "~&" format-string))
109 (:page (extend-string "~|" format-string))
110 (:pretty (extend-string "~A" format-string))
111 (:readable (extend-string "~S" format-string))
112 (:write (extend-string "~W" format-string))))
113 (list
114 ;; handle complex forms
115 (case (first control)
116 (:binary (add-numeric-control #\B (rest control) format-string))
117 (:octal (add-numeric-control #\O (rest control) format-string))
118 (:decimal (add-numeric-control #\D (rest control) format-string))
119 (:hex (add-numeric-control #\X (rest control) format-string))))
120 (number
121 (extend-string control format-string))
122 (t nil))
123 format-string))
124 (process-argument-item (control)
125 (typecase control
126 (symbol (when (not (keywordp control)) control))
127 (list (car (last control)))
128 (t nil))))
129 `(format ,stream
130 ,(collapse-string (cons initial-string (mapcar #'process-control-item args)))
131 ,@(remove-if #'null (mapcar #'process-argument-item args)))))
134 (defun pad2 (i)
135 (logandc1 #X1 (1+ i)))
137 (defun string-id (string)
138 "Convert string into 4byte IFFF id"
139 (logior
140 (ash (char-code (char string 3)) 0)
141 (ash (char-code (char string 2)) 8)
142 (ash (char-code (char string 1)) 16)
143 (ash (char-code (char string 0)) 24)))
145 (defun id-string (id)
146 "Convert 4 byte IFFF id into string"
147 (concatenate 'string
148 (string (code-char (logand #XFF (ash id -24))))
149 (string (code-char (logand #XFF (ash id -16))))
150 (string (code-char (logand #XFF (ash id -8))))
151 (string (code-char (logand #XFF id)))))