Monorepo for Aesthetic.Computer
aesthetic.computer
feat: KidLisp CL-native evaluator — parser, eval, builtins, runner
Tree-walking interpreter for KidLisp in ~1150 lines of Common Lisp.
Replaces the 15,000-line JS evaluator for native OS. Supports:
- Auto-wrapping bare lines, comma separation
- Timing expressions (1s, 2s..., 0.5s!)
- All graphics builtins (wipe, ink, line, box, circle, plot)
- Pixel transforms (scroll, zoom, spin, contrast)
- Math, random, repeat, def/later, if/once/?
- Color names + rainbow/zebra
- Magic vars (w, h, w/2, h/2, frame, width, height)
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+764
-1
+8
-1
fedac/native/cl/ac-native.asd
+8
-1
fedac/native/cl/ac-native.asd
···
34
34
;; QuickJS bridge (JS piece runner)
35
35
(:file "quickjs-ffi")
36
36
(:file "js-bridge")
37
+
;; KidLisp CL-native evaluator
38
+
(:file "kidlisp-package")
39
+
(:file "kidlisp-colors")
40
+
(:file "kidlisp-parser")
41
+
(:file "kidlisp-eval")
42
+
(:file "kidlisp-builtins")
43
+
(:file "kidlisp-runner")
44
+
;; Main + Build
37
45
(:file "main")
38
-
;; Build
39
46
(:file "build")))
+213
fedac/native/cl/kidlisp-builtins.lisp
+213
fedac/native/cl/kidlisp-builtins.lisp
···
1
+
;;; kidlisp-builtins.lisp — Built-in function table for KidLisp
2
+
;;; Each builtin is (lambda (instance evaluated-args) ...)
3
+
4
+
(in-package :ac-native.kidlisp)
5
+
6
+
(defvar *builtins* (make-hash-table :test #'equal))
7
+
8
+
(defmacro defbuiltin (name params &body body)
9
+
`(setf (gethash ,name *builtins*)
10
+
(lambda ,params ,@body)))
11
+
12
+
;;; ── Graphics ──
13
+
14
+
(defbuiltin "wipe" (inst args)
15
+
(let ((rgb (resolve-color args (kidlisp-instance-frame-count inst))))
16
+
(when (kidlisp-instance-graph inst)
17
+
(ac-native.graph:graph-wipe
18
+
(kidlisp-instance-graph inst)
19
+
(ac-native.color:make-color
20
+
:r (first rgb) :g (second rgb) :b (third rgb) :a 255)))))
21
+
22
+
(defbuiltin "ink" (inst args)
23
+
(let ((rgb (resolve-color args (kidlisp-instance-frame-count inst))))
24
+
(setf (kidlisp-instance-ink-r inst) (first rgb)
25
+
(kidlisp-instance-ink-g inst) (second rgb)
26
+
(kidlisp-instance-ink-b inst) (third rgb))
27
+
(when (kidlisp-instance-graph inst)
28
+
(ac-native.graph:graph-ink
29
+
(kidlisp-instance-graph inst)
30
+
(ac-native.color:make-color
31
+
:r (first rgb) :g (second rgb) :b (third rgb) :a 255)))))
32
+
33
+
(defbuiltin "line" (inst args)
34
+
(when (and (kidlisp-instance-graph inst) (>= (length args) 4))
35
+
(ac-native.graph:graph-line
36
+
(kidlisp-instance-graph inst)
37
+
(round (or (nth 0 args) 0)) (round (or (nth 1 args) 0))
38
+
(round (or (nth 2 args) 0)) (round (or (nth 3 args) 0)))))
39
+
40
+
(defbuiltin "box" (inst args)
41
+
(when (and (kidlisp-instance-graph inst) (>= (length args) 4))
42
+
(ac-native.graph:graph-box
43
+
(kidlisp-instance-graph inst)
44
+
(round (or (nth 0 args) 0)) (round (or (nth 1 args) 0))
45
+
(round (or (nth 2 args) 0)) (round (or (nth 3 args) 0))
46
+
1)))
47
+
48
+
(defbuiltin "circle" (inst args)
49
+
(when (and (kidlisp-instance-graph inst) (>= (length args) 3))
50
+
(ac-native.graph:graph-circle
51
+
(kidlisp-instance-graph inst)
52
+
(round (or (nth 0 args) 0)) (round (or (nth 1 args) 0))
53
+
(round (or (nth 2 args) 0)))))
54
+
55
+
(defbuiltin "plot" (inst args)
56
+
(when (and (kidlisp-instance-graph inst) (>= (length args) 2))
57
+
(ac-native.graph:graph-plot
58
+
(kidlisp-instance-graph inst)
59
+
(round (or (nth 0 args) 0)) (round (or (nth 1 args) 0)))))
60
+
61
+
;;; ── Pixel transforms ──
62
+
63
+
(defbuiltin "scroll" (inst args)
64
+
(when (kidlisp-instance-graph inst)
65
+
(let ((dx (round (or (nth 0 args) 0)))
66
+
(dy (round (or (nth 1 args) 0)))
67
+
(fb (ac-native.graph:graph-fb (kidlisp-instance-graph inst))))
68
+
(when fb
69
+
(ac-native.framebuffer:fb-scroll fb dx dy)))))
70
+
71
+
(defbuiltin "zoom" (inst args)
72
+
(when (kidlisp-instance-graph inst)
73
+
(let ((factor (or (nth 0 args) 1.0))
74
+
(fb (ac-native.graph:graph-fb (kidlisp-instance-graph inst))))
75
+
(when (and fb (numberp factor))
76
+
(ac-native.framebuffer:fb-zoom fb factor)))))
77
+
78
+
(defbuiltin "spin" (inst args)
79
+
(when (kidlisp-instance-graph inst)
80
+
(let ((angle (or (nth 0 args) 0.0))
81
+
(fb (ac-native.graph:graph-fb (kidlisp-instance-graph inst))))
82
+
(when (and fb (numberp angle))
83
+
(ac-native.framebuffer:fb-spin fb angle)))))
84
+
85
+
(defbuiltin "contrast" (inst args)
86
+
(when (kidlisp-instance-graph inst)
87
+
(let ((factor (or (nth 0 args) 1.0))
88
+
(fb (ac-native.graph:graph-fb (kidlisp-instance-graph inst))))
89
+
(when (and fb (numberp factor))
90
+
(ac-native.framebuffer:fb-contrast fb factor)))))
91
+
92
+
;;; ── Math ──
93
+
94
+
(defbuiltin "+" (inst args)
95
+
(declare (ignore inst))
96
+
(apply #'+ (remove-if-not #'numberp args)))
97
+
98
+
(defbuiltin "-" (inst args)
99
+
(declare (ignore inst))
100
+
(if (= (length args) 1)
101
+
(- (first args))
102
+
(apply #'- (remove-if-not #'numberp args))))
103
+
104
+
(defbuiltin "*" (inst args)
105
+
(declare (ignore inst))
106
+
(apply #'* (remove-if-not #'numberp args)))
107
+
108
+
(defbuiltin "/" (inst args)
109
+
(declare (ignore inst))
110
+
(if (and (>= (length args) 2) (not (zerop (second args))))
111
+
(/ (float (first args)) (float (second args)))
112
+
0))
113
+
114
+
(defbuiltin "%" (inst args)
115
+
(declare (ignore inst))
116
+
(if (and (>= (length args) 2) (not (zerop (second args))))
117
+
(mod (first args) (second args))
118
+
0))
119
+
(setf (gethash "mod" *builtins*) (gethash "%" *builtins*))
120
+
121
+
(defbuiltin "sin" (inst args)
122
+
(declare (ignore inst))
123
+
(when (numberp (first args)) (sin (float (first args)))))
124
+
125
+
(defbuiltin "cos" (inst args)
126
+
(declare (ignore inst))
127
+
(when (numberp (first args)) (cos (float (first args)))))
128
+
129
+
(defbuiltin "abs" (inst args)
130
+
(declare (ignore inst))
131
+
(when (numberp (first args)) (abs (first args))))
132
+
133
+
(defbuiltin "floor" (inst args)
134
+
(declare (ignore inst))
135
+
(when (numberp (first args)) (floor (first args))))
136
+
137
+
(defbuiltin "ceil" (inst args)
138
+
(declare (ignore inst))
139
+
(when (numberp (first args)) (ceiling (first args))))
140
+
141
+
(defbuiltin "round" (inst args)
142
+
(declare (ignore inst))
143
+
(when (numberp (first args)) (round (first args))))
144
+
145
+
(defbuiltin "sqrt" (inst args)
146
+
(declare (ignore inst))
147
+
(when (and (numberp (first args)) (>= (first args) 0))
148
+
(sqrt (float (first args)))))
149
+
150
+
(defbuiltin "min" (inst args)
151
+
(declare (ignore inst))
152
+
(apply #'min (remove-if-not #'numberp args)))
153
+
154
+
(defbuiltin "max" (inst args)
155
+
(declare (ignore inst))
156
+
(apply #'max (remove-if-not #'numberp args)))
157
+
158
+
(defbuiltin "pow" (inst args)
159
+
(declare (ignore inst))
160
+
(when (and (numberp (first args)) (numberp (second args)))
161
+
(expt (float (first args)) (float (second args)))))
162
+
163
+
(defbuiltin "random" (inst args)
164
+
(let ((n (or (first args) 1)))
165
+
(when (numberp n)
166
+
(if (integerp n)
167
+
(random n (kidlisp-instance-random-state inst))
168
+
(* n (random 1.0 (kidlisp-instance-random-state inst)))))))
169
+
170
+
(defbuiltin "wiggle" (inst args)
171
+
(let ((n (or (first args) 1)))
172
+
(when (numberp n)
173
+
(random n (kidlisp-instance-random-state inst)))))
174
+
175
+
;;; ── System ──
176
+
177
+
(defbuiltin "width" (inst args)
178
+
(declare (ignore args))
179
+
(kidlisp-instance-screen-w inst))
180
+
181
+
(defbuiltin "height" (inst args)
182
+
(declare (ignore args))
183
+
(kidlisp-instance-screen-h inst))
184
+
185
+
(defbuiltin "frame" (inst args)
186
+
(declare (ignore args))
187
+
(kidlisp-instance-frame-count inst))
188
+
189
+
;;; ── Audio (stubs for now) ──
190
+
191
+
(defbuiltin "tone" (inst args)
192
+
(declare (ignore inst args))
193
+
nil)
194
+
195
+
(defbuiltin "overtone" (inst args)
196
+
(declare (ignore inst args))
197
+
nil)
198
+
199
+
(defbuiltin "melody" (inst args)
200
+
(declare (ignore inst args))
201
+
nil)
202
+
203
+
;;; ── Output ──
204
+
205
+
(defbuiltin "log" (inst args)
206
+
(declare (ignore inst))
207
+
(format *error-output* "[kidlisp] ~{~A ~}~%" args)
208
+
(force-output *error-output*))
209
+
210
+
(defbuiltin "print" (inst args)
211
+
(declare (ignore inst))
212
+
(format *error-output* "[kidlisp] ~{~A ~}~%" args)
213
+
(force-output *error-output*))
+85
fedac/native/cl/kidlisp-colors.lisp
+85
fedac/native/cl/kidlisp-colors.lisp
···
1
+
;;; kidlisp-colors.lisp — Color table + rainbow/zebra for KidLisp
2
+
3
+
(in-package :ac-native.kidlisp)
4
+
5
+
(defvar *colors* (make-hash-table :test #'equal))
6
+
7
+
(macrolet ((defcolors (&rest pairs)
8
+
`(progn
9
+
,@(loop for (name r g b) on pairs by #'cddddr
10
+
collect `(setf (gethash ,name *colors*) (list ,r ,g ,b))))))
11
+
(defcolors
12
+
"red" 255 0 0 "green" 0 128 0 "blue" 0 0 255
13
+
"white" 255 255 255 "black" 0 0 0
14
+
"cyan" 0 255 255 "magenta" 255 0 255 "yellow" 255 255 0
15
+
"orange" 255 165 0 "pink" 255 192 203 "purple" 128 0 128
16
+
"lime" 0 255 0 "aqua" 0 255 255 "navy" 0 0 128
17
+
"maroon" 128 0 0 "olive" 128 128 0 "teal" 0 128 128
18
+
"silver" 192 192 192 "gray" 128 128 128 "grey" 128 128 128
19
+
"coral" 255 127 80 "salmon" 250 128 114
20
+
"gold" 255 215 0 "indigo" 75 0 130 "violet" 238 130 238
21
+
"crimson" 220 20 60 "turquoise" 64 224 208))
22
+
23
+
(defun hsv-to-rgb (h s v)
24
+
"Convert HSV (h=0-360, s=0-1, v=0-1) to (r g b) in 0-255."
25
+
(let* ((c (* v s))
26
+
(x (* c (- 1.0 (abs (- (mod (/ h 60.0) 2.0) 1.0)))))
27
+
(m (- v c))
28
+
(r1 0.0) (g1 0.0) (b1 0.0))
29
+
(cond ((< h 60) (setf r1 c g1 x))
30
+
((< h 120) (setf r1 x g1 c))
31
+
((< h 180) (setf g1 c b1 x))
32
+
((< h 240) (setf g1 x b1 c))
33
+
((< h 300) (setf r1 x b1 c))
34
+
(t (setf r1 c b1 x)))
35
+
(list (round (* (+ r1 m) 255))
36
+
(round (* (+ g1 m) 255))
37
+
(round (* (+ b1 m) 255)))))
38
+
39
+
(defun rainbow-color (frame &optional (speed 1.0))
40
+
"Generate a cycling rainbow color based on frame count."
41
+
(hsv-to-rgb (mod (* frame speed 2.0) 360.0) 1.0 1.0))
42
+
43
+
(defun zebra-color (frame)
44
+
"Alternating black/white."
45
+
(if (evenp frame) '(255 255 255) '(0 0 0)))
46
+
47
+
(defun color-name-p (name)
48
+
"Is NAME a known color name, rainbow, or zebra?"
49
+
(or (gethash name *colors*)
50
+
(string= name "rainbow")
51
+
(string= name "zebra")))
52
+
53
+
(defun resolve-color (args frame)
54
+
"Resolve KidLisp color arguments to (r g b).
55
+
ARGS can be: a color name string, (r g b) numbers, 'rainbow', 'zebra',
56
+
or a single grayscale number."
57
+
(cond
58
+
((null args) '(255 255 255))
59
+
;; Single string: color name
60
+
((and (= (length args) 1) (stringp (first args)))
61
+
(let ((name (first args)))
62
+
(cond ((string= name "rainbow") (rainbow-color frame))
63
+
((string= name "zebra") (zebra-color frame))
64
+
((gethash name *colors*) (gethash name *colors*))
65
+
(t '(255 255 255)))))
66
+
;; Single number: grayscale
67
+
((and (= (length args) 1) (numberp (first args)))
68
+
(let ((v (max 0 (min 255 (round (first args))))))
69
+
(list v v v)))
70
+
;; Three numbers: r g b
71
+
((and (>= (length args) 3)
72
+
(numberp (first args))
73
+
(numberp (second args))
74
+
(numberp (third args)))
75
+
(list (max 0 (min 255 (round (first args))))
76
+
(max 0 (min 255 (round (second args))))
77
+
(max 0 (min 255 (round (third args))))))
78
+
;; Four numbers: r g b a (ignore alpha for now)
79
+
((and (>= (length args) 4)
80
+
(numberp (first args)))
81
+
(list (max 0 (min 255 (round (first args))))
82
+
(max 0 (min 255 (round (second args))))
83
+
(max 0 (min 255 (round (third args))))))
84
+
;; Fallback
85
+
(t '(255 255 255))))
+227
fedac/native/cl/kidlisp-eval.lisp
+227
fedac/native/cl/kidlisp-eval.lisp
···
1
+
;;; kidlisp-eval.lisp — Tree-walking interpreter for KidLisp
2
+
3
+
(in-package :ac-native.kidlisp)
4
+
5
+
(defstruct kidlisp-instance
6
+
(ast nil)
7
+
(global-def (make-hash-table :test #'equal))
8
+
(frame-count 0 :type fixnum)
9
+
(once-executed (make-hash-table :test #'equal))
10
+
(timing-last (make-hash-table :test #'equal))
11
+
(timing-seq (make-hash-table :test #'equal))
12
+
(random-state (make-random-state t))
13
+
;; Graphics state (set each frame)
14
+
graph
15
+
screen-w
16
+
screen-h
17
+
audio
18
+
(ink-r 255) (ink-g 255) (ink-b 255))
19
+
20
+
(defun kidlisp-frame (inst)
21
+
"Increment frame counter and evaluate the AST for one frame."
22
+
(incf (kidlisp-instance-frame-count inst))
23
+
(kidlisp-eval inst (kidlisp-instance-ast inst) nil))
24
+
25
+
;;; ── Variable resolution ──
26
+
27
+
(defun lookup-var (inst name env)
28
+
"Resolve a variable: env -> global-def -> magic vars -> color."
29
+
(or (cdr (assoc name env :test #'equal))
30
+
(gethash name (kidlisp-instance-global-def inst))
31
+
(magic-var inst name)
32
+
(when (color-name-p name) name)))
33
+
34
+
(defun magic-var (inst name)
35
+
"Resolve magic variables: width, height, w, h, w/2, h/2, frame."
36
+
(let ((sw (kidlisp-instance-screen-w inst))
37
+
(sh (kidlisp-instance-screen-h inst)))
38
+
(cond
39
+
((or (string= name "width") (string= name "w")) sw)
40
+
((or (string= name "height") (string= name "h")) sh)
41
+
((string= name "w/2") (floor sw 2))
42
+
((string= name "h/2") (floor sh 2))
43
+
((string= name "frame") (kidlisp-instance-frame-count inst))
44
+
(t nil))))
45
+
46
+
;;; ── Timing ──
47
+
48
+
(defun parse-timing (head)
49
+
"Parse a timing token. Returns (seconds iterating-p bang-p) or NIL."
50
+
(when (timing-token-p head)
51
+
(let* ((has-dots (search "..." head))
52
+
(has-bang (and (not has-dots) (find #\! head)))
53
+
(num-str (string-right-trim ".!s" head)))
54
+
(let ((secs (or (parse-number num-str) 1.0)))
55
+
(values secs (not (null has-dots)) (not (null has-bang)))))))
56
+
57
+
(defun handle-timing (inst secs iterating-p args env)
58
+
"Handle timed execution. Returns the evaluated body at the right interval."
59
+
(let* ((key (format nil "~A:~A" secs args))
60
+
(now (/ (get-internal-real-time) (float internal-time-units-per-second)))
61
+
(last (gethash key (kidlisp-instance-timing-last inst) 0.0)))
62
+
(when (>= (- now last) secs)
63
+
(setf (gethash key (kidlisp-instance-timing-last inst)) now)
64
+
(if iterating-p
65
+
;; Iterating: cycle through args
66
+
(let* ((idx (gethash key (kidlisp-instance-timing-seq inst) 0))
67
+
(val (nth (mod idx (length args)) args)))
68
+
(setf (gethash key (kidlisp-instance-timing-seq inst)) (1+ idx))
69
+
(kidlisp-eval inst val env))
70
+
;; Single execution
71
+
(let ((result nil))
72
+
(dolist (a args result)
73
+
(setf result (kidlisp-eval inst a env))))))))
74
+
75
+
;;; ── Core evaluator ──
76
+
77
+
(defun kidlisp-eval (inst expr env)
78
+
"Evaluate a KidLisp expression."
79
+
(cond
80
+
;; NIL
81
+
((null expr) nil)
82
+
;; Number
83
+
((numberp expr) expr)
84
+
;; String atom (variable or color name)
85
+
((stringp expr)
86
+
(or (lookup-var inst expr env) expr))
87
+
;; List (function call or special form)
88
+
((listp expr)
89
+
(let ((head (first expr))
90
+
(args (rest expr)))
91
+
(cond
92
+
;; Empty list
93
+
((null head) nil)
94
+
;; Head is a list (nested expression) — evaluate head first
95
+
((listp head)
96
+
(let ((result (kidlisp-eval inst head env)))
97
+
(declare (ignore result))
98
+
;; Evaluate remaining as sequence
99
+
(let ((last nil))
100
+
(dolist (a args last)
101
+
(setf last (kidlisp-eval inst a env))))))
102
+
;; Timing token
103
+
((timing-token-p head)
104
+
(multiple-value-bind (secs iterating-p) (parse-timing head)
105
+
(handle-timing inst secs iterating-p args env)))
106
+
;; Integer as timing shorthand (e.g., (2 body...) = every 2 frames)
107
+
((and (numberp head) (integerp head) args)
108
+
(when (zerop (mod (kidlisp-instance-frame-count inst) head))
109
+
(let ((result nil))
110
+
(dolist (a args result)
111
+
(setf result (kidlisp-eval inst a env))))))
112
+
;; String head — function call or special form
113
+
((stringp head)
114
+
(eval-call inst head args env))
115
+
;; Fallback
116
+
(t nil))))
117
+
;; Fallback
118
+
(t expr)))
119
+
120
+
(defun eval-call (inst head args env)
121
+
"Evaluate a named function call or special form."
122
+
(cond
123
+
;; ── Special forms (don't pre-evaluate args) ──
124
+
((string= head "progn")
125
+
(let ((result nil))
126
+
(dolist (a args result)
127
+
(setf result (kidlisp-eval inst a env)))))
128
+
129
+
((string= head "def")
130
+
(when (>= (length args) 2)
131
+
(let ((name (first args))
132
+
(val (kidlisp-eval inst (second args) env)))
133
+
(when (stringp name)
134
+
(setf (gethash name (kidlisp-instance-global-def inst)) val)))))
135
+
136
+
((string= head "later")
137
+
;; (later name (params...) body...)
138
+
(when (>= (length args) 2)
139
+
(let ((name (first args))
140
+
(params (if (listp (second args)) (second args) nil))
141
+
(body (if (listp (second args)) (cddr args) (cdr args))))
142
+
(when (stringp name)
143
+
(setf (gethash name (kidlisp-instance-global-def inst))
144
+
(list :later params body))))))
145
+
146
+
((string= head "if")
147
+
(let ((cond-val (kidlisp-eval inst (first args) env)))
148
+
(if (and cond-val (not (eql cond-val 0)))
149
+
(kidlisp-eval inst (second args) env)
150
+
(when (third args)
151
+
(kidlisp-eval inst (third args) env)))))
152
+
153
+
((string= head "not")
154
+
(let ((val (kidlisp-eval inst (first args) env)))
155
+
(if (and val (not (eql val 0))) 0 1)))
156
+
157
+
((string= head "once")
158
+
(let ((key (format nil "once:~A" args)))
159
+
(unless (gethash key (kidlisp-instance-once-executed inst))
160
+
(setf (gethash key (kidlisp-instance-once-executed inst)) t)
161
+
(let ((result nil))
162
+
(dolist (a args result)
163
+
(setf result (kidlisp-eval inst a env)))))))
164
+
165
+
((or (string= head "?") (string= head "choose"))
166
+
;; Random choice from args
167
+
(when args
168
+
(let ((idx (random (length args) (kidlisp-instance-random-state inst))))
169
+
(kidlisp-eval inst (nth idx args) env))))
170
+
171
+
((string= head "repeat")
172
+
;; (repeat N [i] body...)
173
+
(let* ((n (kidlisp-eval inst (first args) env))
174
+
(count (if (numberp n) (round n) 0))
175
+
(has-iter (and (>= (length args) 3) (stringp (second args))))
176
+
(iter-name (when has-iter (second args)))
177
+
(body (if has-iter (cddr args) (cdr args))))
178
+
(let ((result nil))
179
+
(dotimes (i count result)
180
+
(let ((new-env (if iter-name
181
+
(acons iter-name i env)
182
+
env)))
183
+
(dolist (b body)
184
+
(setf result (kidlisp-eval inst b new-env))))))))
185
+
186
+
;; ── Comparison operators ──
187
+
((string= head ">")
188
+
(let ((a (kidlisp-eval inst (first args) env))
189
+
(b (kidlisp-eval inst (second args) env)))
190
+
(if (and (numberp a) (numberp b) (> a b)) 1 0)))
191
+
((string= head "<")
192
+
(let ((a (kidlisp-eval inst (first args) env))
193
+
(b (kidlisp-eval inst (second args) env)))
194
+
(if (and (numberp a) (numberp b) (< a b)) 1 0)))
195
+
((string= head "=")
196
+
(let ((a (kidlisp-eval inst (first args) env))
197
+
(b (kidlisp-eval inst (second args) env)))
198
+
(if (equal a b) 1 0)))
199
+
200
+
;; ── Built-in functions (evaluate args first) ──
201
+
(t
202
+
(let ((evaled (mapcar (lambda (a) (kidlisp-eval inst a env)) args)))
203
+
(call-builtin inst head evaled)))))
204
+
205
+
(defun call-builtin (inst name args)
206
+
"Call a built-in KidLisp function with evaluated args."
207
+
(let ((fn (gethash name *builtins*)))
208
+
(if fn
209
+
(funcall fn inst args)
210
+
;; Check user-defined (later) functions
211
+
(let ((def (gethash name (kidlisp-instance-global-def inst))))
212
+
(cond
213
+
((and (listp def) (eq (first def) :later))
214
+
(let* ((params (second def))
215
+
(body (third def))
216
+
(env (mapcar #'cons
217
+
(mapcar (lambda (p) (if (stringp p) p (format nil "~A" p)))
218
+
params)
219
+
args)))
220
+
(let ((result nil))
221
+
(dolist (b body result)
222
+
(setf result (kidlisp-eval inst b env))))))
223
+
;; If it resolves to a color, return it
224
+
((color-name-p name)
225
+
(resolve-color (list name) (kidlisp-instance-frame-count inst)))
226
+
;; Unknown — return nil silently
227
+
(t nil))))))
+10
fedac/native/cl/kidlisp-package.lisp
+10
fedac/native/cl/kidlisp-package.lisp
+134
fedac/native/cl/kidlisp-parser.lisp
+134
fedac/native/cl/kidlisp-parser.lisp
···
1
+
;;; kidlisp-parser.lisp — Tokenizer + reader for KidLisp dialect
2
+
;;; Handles auto-wrapping bare lines, comma separation, timing syntax.
3
+
4
+
(in-package :ac-native.kidlisp)
5
+
6
+
(defun timing-token-p (s)
7
+
"Is S a timing token like '1s', '2s...', '0.5s!'?"
8
+
(and (stringp s)
9
+
(> (length s) 1)
10
+
(let ((base (string-right-trim ".!" s)))
11
+
(and (> (length base) 0)
12
+
(char= (char base (1- (length base))) #\s)
13
+
(every (lambda (c) (or (digit-char-p c) (char= c #\.)))
14
+
(subseq base 0 (1- (length base))))))))
15
+
16
+
(defun parse-number (s)
17
+
"Try to parse S as a number. Returns number or NIL."
18
+
(handler-case
19
+
(let ((n (read-from-string s)))
20
+
(when (numberp n) n))
21
+
(error () nil)))
22
+
23
+
(defun tokenize (source)
24
+
"Split KidLisp source into tokens (strings)."
25
+
(let ((tokens nil)
26
+
(i 0)
27
+
(len (length source)))
28
+
(flet ((peek () (when (< i len) (char source i)))
29
+
(advance () (prog1 (char source i) (incf i))))
30
+
(loop while (< i len) do
31
+
(let ((c (peek)))
32
+
(cond
33
+
;; Whitespace
34
+
((member c '(#\Space #\Tab #\Newline #\Return))
35
+
(advance))
36
+
;; Comment
37
+
((char= c #\;)
38
+
(loop while (and (< i len) (not (char= (peek) #\Newline)))
39
+
do (advance)))
40
+
;; Parens and comma
41
+
((char= c #\() (push "(" tokens) (advance))
42
+
((char= c #\)) (push ")" tokens) (advance))
43
+
((char= c #\,) (advance)) ; skip commas as separators
44
+
;; Quoted string
45
+
((or (char= c #\") (char= c #\'))
46
+
(let ((quote c)
47
+
(start i))
48
+
(advance) ; skip opening quote
49
+
(loop while (and (< i len) (not (char= (peek) quote)))
50
+
do (when (char= (peek) #\\) (advance)) ; skip escape
51
+
(advance))
52
+
(when (< i len) (advance)) ; skip closing quote
53
+
(push (subseq source (1+ start) (1- i)) tokens)))
54
+
;; Atom (symbol, number, color name, timing token)
55
+
(t
56
+
(let ((start i))
57
+
(loop while (and (< i len)
58
+
(not (member (peek) '(#\Space #\Tab #\Newline #\Return
59
+
#\( #\) #\, #\;))))
60
+
do (advance))
61
+
(push (subseq source start i) tokens)))))))
62
+
(nreverse tokens)))
63
+
64
+
(defun bare-line-p (line)
65
+
"Is LINE a bare expression that needs auto-wrapping in parens?
66
+
Bare lines start with a word (not a paren) and have arguments."
67
+
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
68
+
(and (> (length trimmed) 0)
69
+
(not (char= (char trimmed 0) #\())
70
+
(not (char= (char trimmed 0) #\;))
71
+
;; Has a space (i.e., has arguments)
72
+
(position #\Space trimmed))))
73
+
74
+
(defun preprocess (source)
75
+
"Pre-process KidLisp source: auto-wrap bare lines, handle commas."
76
+
(let ((lines (uiop:split-string source :separator '(#\Newline))))
77
+
;; Process each line
78
+
(let ((processed
79
+
(mapcar (lambda (line)
80
+
(let ((trimmed (string-trim '(#\Space #\Tab #\Return) line)))
81
+
(cond
82
+
;; Empty or comment
83
+
((or (= (length trimmed) 0)
84
+
(char= (char trimmed 0) #\;))
85
+
"")
86
+
;; Already wrapped in parens
87
+
((char= (char trimmed 0) #\()
88
+
trimmed)
89
+
;; Bare line: auto-wrap
90
+
((bare-line-p trimmed)
91
+
(format nil "(~A)" trimmed))
92
+
;; Single word (color name on line 1, etc.)
93
+
(t trimmed))))
94
+
lines)))
95
+
;; Join all lines, wrap in implicit progn
96
+
(format nil "(progn ~{~A ~})" processed))))
97
+
98
+
(defun read-tokens (tokens)
99
+
"Read a list of tokens into a nested list AST."
100
+
(let ((pos 0))
101
+
(labels ((read-expr ()
102
+
(when (>= pos (length tokens))
103
+
(return-from read-expr nil))
104
+
(let ((tok (nth pos tokens)))
105
+
(cond
106
+
((string= tok "(")
107
+
(incf pos)
108
+
(let ((items nil))
109
+
(loop while (and (< pos (length tokens))
110
+
(not (string= (nth pos tokens) ")")))
111
+
do (push (read-expr) items))
112
+
(when (and (< pos (length tokens))
113
+
(string= (nth pos tokens) ")"))
114
+
(incf pos))
115
+
(nreverse items)))
116
+
((string= tok ")")
117
+
(incf pos)
118
+
nil)
119
+
(t
120
+
(incf pos)
121
+
;; Try to parse as number
122
+
(or (parse-number tok) tok))))))
123
+
(let ((results nil))
124
+
(loop while (< pos (length tokens))
125
+
do (push (read-expr) results))
126
+
(if (= (length results) 1)
127
+
(first results)
128
+
(cons "progn" (nreverse results)))))))
129
+
130
+
(defun kidlisp-parse (source)
131
+
"Parse KidLisp source string into an AST (nested lists)."
132
+
(let* ((preprocessed (preprocess source))
133
+
(tokens (tokenize preprocessed)))
134
+
(read-tokens tokens)))
+87
fedac/native/cl/kidlisp-runner.lisp
+87
fedac/native/cl/kidlisp-runner.lisp
···
1
+
;;; kidlisp-runner.lisp — Run KidLisp pieces in the CL main loop
2
+
3
+
(in-package :ac-native.kidlisp)
4
+
5
+
(defun run-kidlisp-piece (source &key (label "$code"))
6
+
"Run a KidLisp piece with full DRM graphics, audio, and input.
7
+
SOURCE is the KidLisp source code string."
8
+
(format *error-output* "~%════════════════════════════════════~%")
9
+
(format *error-output* " KidLisp (~A)~%" label)
10
+
(format *error-output* " SBCL ~A~%" (lisp-implementation-version))
11
+
(format *error-output* "════════════════════════════════════~%~%")
12
+
(force-output *error-output*)
13
+
14
+
;; Parse the source
15
+
(let ((ast (handler-case (kidlisp-parse source)
16
+
(error (e)
17
+
(format *error-output* "[kidlisp] Parse error: ~A~%" e)
18
+
(force-output *error-output*)
19
+
(return-from run-kidlisp-piece)))))
20
+
(format *error-output* "[kidlisp] Parsed ~A: ~A top-level forms~%"
21
+
label (if (and (listp ast) (string= (first ast) "progn"))
22
+
(1- (length ast))
23
+
1))
24
+
(force-output *error-output*)
25
+
26
+
;; Initialize display
27
+
(let ((display (ac-native.drm:drm-init)))
28
+
(unless display
29
+
(format *error-output* "[kidlisp] DRM init failed~%")
30
+
(return-from run-kidlisp-piece))
31
+
32
+
(let* ((dw (ac-native.drm:display-width display))
33
+
(dh (ac-native.drm:display-height display))
34
+
(scale (cond ((>= (min dw dh) 1440) 6)
35
+
((>= (min dw dh) 1080) 4)
36
+
((>= (min dw dh) 720) 3)
37
+
(t 2)))
38
+
(sw (floor dw scale))
39
+
(sh (floor dh scale))
40
+
(screen (ac-native.framebuffer:fb-create sw sh))
41
+
(graph (ac-native.graph:graph-create screen))
42
+
(input (ac-native.input:input-init dw dh scale))
43
+
(audio (ac-native.audio:audio-init)))
44
+
45
+
(format *error-output* "[kidlisp] ~Dx~D scale:~D -> ~Dx~D~%" dw dh scale sw sh)
46
+
(force-output *error-output*)
47
+
48
+
;; Create KidLisp instance
49
+
(let ((inst (make-kidlisp-instance
50
+
:ast ast
51
+
:graph graph
52
+
:screen-w sw
53
+
:screen-h sh
54
+
:audio audio)))
55
+
56
+
;; Main loop
57
+
(unwind-protect
58
+
(let ((running t))
59
+
(loop while running do
60
+
;; Input
61
+
(ac-native.input:input-poll input)
62
+
(dotimes (i (ac-native.input:input-event-count input))
63
+
(let ((ev (ac-native.input:input-event input i)))
64
+
(when (and (= (ac-native.input:event-type ev) 1) ; keyboard down
65
+
(= (ac-native.input:event-code ev) 1)) ; ESC
66
+
(setf running nil))))
67
+
68
+
;; Evaluate one frame
69
+
(handler-case
70
+
(kidlisp-frame inst)
71
+
(error (e)
72
+
(format *error-output* "[kidlisp] Runtime error: ~A~%" e)
73
+
(force-output *error-output*)))
74
+
75
+
;; Present
76
+
(ac-native.drm:drm-present display screen scale)
77
+
78
+
;; 60fps sync
79
+
(sleep 1/60)))
80
+
81
+
;; Cleanup
82
+
(when audio (ac-native.audio:audio-destroy audio))
83
+
(ac-native.input:input-destroy input)
84
+
(ac-native.framebuffer:fb-destroy screen)
85
+
(ac-native.drm:drm-destroy display)
86
+
(format *error-output* "[kidlisp] Exited~%")
87
+
(force-output *error-output*)))))))