A categorical programming language
修订版 | 44f9b79e409a4a3fea7cb1280bf0ae88707ba26f (tree) |
---|---|
时间 | 2021-09-29 15:10:42 |
作者 | Corbin <cds@corb...> |
Commiter | Corbin |
Start drawing pictures.
@@ -1,6 +1,7 @@ | ||
1 | 1 | #!@bash@/bin/bash |
2 | 2 | |
3 | -set -eux -o pipefail | |
3 | +# set -x | |
4 | +set -eu -o pipefail | |
4 | 5 | |
5 | 6 | export CHICKEN_REPOSITORY_PATH=@CHICKEN_REPOSITORY_PATH@ |
6 | 7 | export CHICKEN_INCLUDE_PATH=@CHICKEN_INCLUDE_PATH@ |
@@ -12,9 +13,11 @@ movelist="@movelist@/bin/movelist" | ||
12 | 13 | # Configure a temporary directory. |
13 | 14 | tmpdir=$(mktemp -d) |
14 | 15 | |
15 | -# Get the hive and the program to compile. | |
16 | -hive="$1" | |
17 | -input="$2" | |
16 | +# Get the compilation mode, hive, and program to compile. | |
17 | +mode="$1" | |
18 | +printf "Compilation mode: %s\n" "$mode" | |
19 | +hive="$2" | |
20 | +input="$3" | |
18 | 21 | |
19 | 22 | fullname=$(basename -- $input) |
20 | 23 | name="${fullname%.*}" |
@@ -28,7 +31,7 @@ ty=$($movelist type-check <"$tmpdir/program.cammy") | ||
28 | 31 | |
29 | 32 | # Compute the final piece. |
30 | 33 | sed -i -e 's,case,cammy-case,g' -e 's,cons,cammy-cons,g' -e 's,map,cammy-map,g' "$tmpdir/program.cammy" |
31 | -cat stub.scm <(echo '(cammy-run') "$tmpdir/program.cammy" <(echo "'$ty)") >"$tmpdir/$name.scm" | |
34 | +cat stub.scm <(printf '(cammy-%s' "$1") "$tmpdir/program.cammy" <(echo "'$ty)") >"$tmpdir/$name.scm" | |
32 | 35 | # Compile with Chicken. |
33 | 36 | @chicken@/bin/csc -static -O3 -o "$name" "$tmpdir/$name.scm" |
34 | 37 |
@@ -0,0 +1 @@ | ||
1 | +(pair @0 (pair @1 @2)) |
@@ -1,6 +1,7 @@ | ||
1 | -(import (srfi 6) (srfi 144) (srfi 189)) | |
1 | +(import (srfi 4) (srfi 6) (srfi 144) (srfi 189)) | |
2 | 2 | (import (chicken condition) (chicken format) (chicken process-context) (chicken string)) |
3 | 3 | (import (matchable)) |
4 | +(import (stb-image-write)) | |
4 | 5 | |
5 | 6 | (define id (lambda (x) x)) |
6 | 7 | (define (comp f g) (lambda (x) (g (f x)))) |
@@ -39,8 +40,8 @@ | ||
39 | 40 | (define (fold x f) |
40 | 41 | (lambda (l) (if (null? l) (x '()) (f (cons (car l) ((fold x f) (cdr l))))))) |
41 | 42 | |
42 | -(define f-zero (flonum 0.0)) | |
43 | -(define f-one (flonum 1.0)) | |
43 | +(define f-zero (lambda (x) (flonum 0.0))) | |
44 | +(define f-one (lambda (x) (flonum 1.0))) | |
44 | 45 | (define (f-negate x) (fl- x)) |
45 | 46 | (define (f-lt xy) (fl<? (car xy) (cdr xy))) |
46 | 47 | (define (f-add xy) (fl+ (car xy) (cdr xy))) |
@@ -71,8 +72,10 @@ | ||
71 | 72 | (pair2 (p2 args2)) (y (car pair2)) (args3 (cdr pair2))) |
72 | 73 | (cons (cons x y) args3)))) |
73 | 74 | |
75 | +(define (argv) (map read-string (command-line-arguments))) | |
76 | + | |
74 | 77 | (define (parse-args parser) |
75 | - (parser (map read-string (command-line-arguments)))) | |
78 | + (parser (argv))) | |
76 | 79 | |
77 | 80 | (define ty-parse (match-lambda |
78 | 81 | ['N arg-nat] |
@@ -80,8 +83,49 @@ | ||
80 | 83 | [('list x) (arg-list (ty-parse x))] |
81 | 84 | [('pair x y) (arg-pair (ty-parse x) (ty-parse y))])) |
82 | 85 | |
83 | -(define (cammy-run program ty) | |
86 | +; Run a program once using argv for parameters. | |
87 | +(define (cammy-oneshot program ty) | |
84 | 88 | (let* |
85 | 89 | ((input (car (parse-args (ty-parse (car ty))))) |
86 | 90 | (rv (program input))) |
87 | 91 | (begin (display rv) (newline)))) |
92 | + | |
93 | + | |
94 | +(define (viewport width height) | |
95 | + (let* | |
96 | + ((aspect (/ width height)) | |
97 | + (iw (/ width)) | |
98 | + (ih (/ height)) | |
99 | + (dw (* 0.5 iw)) | |
100 | + (dh (* 0.5 ih))) | |
101 | + (lambda (i) | |
102 | + (let ((w (modulo i width)) (h (/ i width))) | |
103 | + (cons (+ dw (* iw w)) (+ dh (* ih h))))))) | |
104 | + | |
105 | +(define (finish-channel c) | |
106 | + (inexact->exact (round (* 255 (max 0.0 (min 1.0 c)))))) | |
107 | + | |
108 | +(define ((draw-pixel program vp) i) | |
109 | + (let* | |
110 | + ((color (program (vp i))) | |
111 | + (r (car color)) | |
112 | + (g (car (cdr color))) | |
113 | + (b (cdr (cdr color)))) | |
114 | + (map finish-channel (list r g b)))) | |
115 | + | |
116 | +(define (count-to i) (if (eqv? 0 i) '() (cons (- i 1) (count-to (- i 1))))) | |
117 | + | |
118 | +(define ((draw-png program width height)) | |
119 | + (let | |
120 | + ((vp (viewport width height)) | |
121 | + (indices (count-to (* width height)))) | |
122 | + (write-png (list->u8vector | |
123 | + (flatten (map (draw-pixel program vp) indices))) | |
124 | + width height 3))) | |
125 | + | |
126 | +; Run a program repeatedly and draw the results. | |
127 | +(define (cammy-draw program ty) | |
128 | + (match (argv) | |
129 | + [(width height filename) | |
130 | + (with-output-to-file filename | |
131 | + (draw-png program width height))])) |