A categorical programming language
Revision | ebd7182e841cb0cda535c8f84eaf0383d14a2130 (tree) |
---|---|
Time | 2021-09-16 08:38:09 |
Author | Corbin <cds@corb...> |
Commiter | Corbin |
Add initial floating-point support.
@@ -4,7 +4,8 @@ module CodeCache = Map.Make (String) | ||
4 | 4 | |
5 | 5 | let primitives = |
6 | 6 | "id comp ignore fst snd pair left right case assl assr swap dup curry \ |
7 | - uncurry app name zero succ for nil cons map fold t f not conj disj" | |
7 | + uncurry app name zero succ pr nil cons map fold t f not conj disj \ | |
8 | + f-zero f-one f-negate f-add f-mul f-sqrt" | |
8 | 9 | |
9 | 10 | let filter = |
10 | 11 | List.fold_left |
@@ -0,0 +1,3 @@ | ||
1 | +(pair | |
2 | + (comp (pair (comp fst fst) (comp snd fst)) f-add) | |
3 | + (comp (pair (comp fst snd) (comp snd snd)) f-add)) |
@@ -0,0 +1,2 @@ | ||
1 | +(pair (comp (pair (comp fst fst) (comp snd fst)) f-add) | |
2 | + (comp (pair (comp fst snd) (comp snd snd)) f/add2)) |
@@ -0,0 +1,5 @@ | ||
1 | +(comp | |
2 | + (pair | |
3 | + (comp (pair (comp fst fst) (comp snd fst)) f-mul) | |
4 | + (comp (pair (comp fst snd) (comp snd snd)) f-mul)) | |
5 | + f-add) |
@@ -0,0 +1,5 @@ | ||
1 | +(comp | |
2 | + (pair | |
3 | + (comp (pair (comp fst fst) (comp snd fst)) f-mul) | |
4 | + (comp (pair (comp fst snd) (comp snd snd)) f/dot2)) | |
5 | + f-add) |
@@ -0,0 +1 @@ | ||
1 | +(comp f/sub3 (comp (comp dup f/dot3) f-sqrt)) |
@@ -0,0 +1,2 @@ | ||
1 | +(pair (comp fst f-negate) | |
2 | + (pair (comp (comp snd fst) f-negate) (comp (comp snd snd) f-negate))) |
@@ -0,0 +1 @@ | ||
1 | +(comp dup f-mul) |
@@ -0,0 +1 @@ | ||
1 | +(comp (pair fst (comp snd f-negate)) f-add) |
@@ -0,0 +1 @@ | ||
1 | +(comp (pair fst (comp snd f/negate3)) f/add3) |
@@ -12,14 +12,20 @@ | ||
12 | 12 | ; constructors before trivial constructors. |
13 | 13 | (conde |
14 | 14 | ; Literal s and t. |
15 | - ((== expr 't) (== s 'unit) (== t 'truth)) | |
16 | - ((== expr 'f) (== s 'unit) (== t 'truth)) | |
17 | - ((== expr 'not) (== s 'truth) (== t 'truth)) | |
18 | - ((== expr 'conj) (== s (cons 'truth 'truth)) (== t 'truth)) | |
19 | - ((== expr 'disj) (== s (cons 'truth 'truth)) (== t 'truth)) | |
15 | + ((== expr 'conj) (== s (list 'pair 'truth 'truth)) (== t 'truth)) | |
16 | + ((== expr 'disj) (== s (list 'pair 'truth 'truth)) (== t 'truth)) | |
17 | + ((== expr 'f-add) (== s (list 'pair 'F 'F)) (== t 'F)) | |
18 | + ((== expr 'f-mul) (== s (list 'pair 'F 'F)) (== t 'F)) | |
20 | 19 | ; Compound before trivial. |
21 | 20 | ((== expr 'succ) (== s 'N) (== t 'N)) |
22 | 21 | ((== expr 'zero) (== s 'unit) (== t 'N)) |
22 | + ((== expr 't) (== s 'unit) (== t 'truth)) | |
23 | + ((== expr 'f) (== s 'unit) (== t 'truth)) | |
24 | + ((== expr 'not) (== s 'truth) (== t 'truth)) | |
25 | + ((== expr 'f-zero) (== s 'unit) (== t 'F)) | |
26 | + ((== expr 'f-one) (== s 'unit) (== t 'F)) | |
27 | + ((== expr 'f-negate) (== s 'F) (== t 'F)) | |
28 | + ((== expr 'f-sqrt) (== s 'F) (== t 'F)) | |
23 | 29 | ; Literal s, recursive t. |
24 | 30 | ((fresh (f x y) (== expr (list 'name f)) |
25 | 31 | (== s 'unit) (== t (list 'hom x y)) (cammyo f x y))) |
@@ -8,7 +8,7 @@ in pkgs.stdenv.mkDerivation { | ||
8 | 8 | gdb |
9 | 9 | # debugging stub.scm |
10 | 10 | chicken rlwrap ] ++ |
11 | - (with chickenPackages.chickenEggs; [ srfi-189 mini-kanren ]) ++ [ | |
11 | + (with chickenPackages.chickenEggs; [ srfi-144 srfi-189 mini-kanren ]) ++ [ | |
12 | 12 | # maintaining frame/ |
13 | 13 | ocamlformat |
14 | 14 | # working with sexps |
@@ -1,4 +1,4 @@ | ||
1 | -(import (srfi 6) (srfi 189)) | |
1 | +(import (srfi 6) (srfi 144) (srfi 189)) | |
2 | 2 | (import (chicken condition) (chicken format) (chicken process-context) (chicken string)) |
3 | 3 | (import (matchable)) |
4 | 4 |
@@ -35,6 +35,13 @@ | ||
35 | 35 | (define (fold x f) |
36 | 36 | (lambda (l) (if (null? l) (x '()) (f (cons (car l) ((fold x f) (cdr l))))))) |
37 | 37 | |
38 | +(define f-zero (flonum 0.0)) | |
39 | +(define f-one (flonum 1.0)) | |
40 | +(define (f-negate x) (fl- x)) | |
41 | +(define (f-add xy) (fl+ (car xy) (cdr xy))) | |
42 | +(define (f-mul xy) (fl* (car xy) (cdr xy))) | |
43 | +(define (f-sqrt x) (flsqrt x)) | |
44 | + | |
38 | 45 | (define (read-string s) (read (open-input-string s))) |
39 | 46 | (define (arg-error arg why) |
40 | 47 | (signal (condition (list 'exn 'message (sprintf "Invalid argument ~A: ~A" arg why))))) |
@@ -45,9 +52,10 @@ | ||
45 | 52 | (define (arg-nat args) |
46 | 53 | (let ((x (car args))) |
47 | 54 | (if (>= x 0) (cons x (cdr args)) (arg-error x "not a natural number")))) |
48 | -(define (arg-int args) | |
55 | +(define (arg-fp args) | |
49 | 56 | (let ((x (car args))) |
50 | - (if (number? x) (cons x (cdr args)) (arg-error x "not an integer")))) | |
57 | + (if (flonum? x) (cons x (cdr args)) | |
58 | + (arg-error x "not a floating-point number")))) | |
51 | 59 | (define (arg-pair p1 p2) |
52 | 60 | (lambda (args1) |
53 | 61 | (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1)) |
@@ -59,6 +67,7 @@ | ||
59 | 67 | |
60 | 68 | (define ty-parse (match-lambda |
61 | 69 | ['N arg-nat] |
70 | + ['F arg-fp] | |
62 | 71 | [('pair x y) (arg-pair (ty-parse x) (ty-parse y))])) |
63 | 72 | |
64 | 73 | (define (cammy-run program ty) |