Commit: ebd7182e841cb0cda535c8f84eaf0383d14a2130 - cammy (git)

A categorical programming language

Commit MetaInfo

• Revision: ebd7182e841cb0cda535c8f84eaf0383d14a2130 (tree)
• Time: 2021-09-16 08:38:09
• Author: Corbin <cds@corb...>
• Commiter: Corbin

Log Message

Add initial floating-point support.

Change Summary

• modified: frame/frame.ml
• add: hive/f/add2.cammy
• add: hive/f/add3.cammy
• add: hive/f/dot2.cammy
• add: hive/f/dot3.cammy
• add: hive/f/euclidean3.cammy
• add: hive/f/negate3.cammy
• add: hive/f/sqr.cammy
• add: hive/f/sub.cammy
• add: hive/f/sub3.cammy
• modified: movelist/movelist.scm
• modified: shell.nix
• modified: stub.scm

Incremental Difference

--- a/frame/frame.ml
+++ b/frame/frame.ml
@@ -4,7 +4,8 @@ module CodeCache = Map.Make (String)
 
 let primitives =
   "id comp ignore fst snd pair left right case assl assr swap dup curry \
-   uncurry app name zero succ for nil cons map fold t f not conj disj"
+   uncurry app name zero succ pr nil cons map fold t f not conj disj \
+   f-zero f-one f-negate f-add f-mul f-sqrt"
 
 let filter =
   List.fold_left

--- /dev/null
+++ b/hive/f/add2.cammy
@@ -0,0 +1,3 @@
+(pair
+  (comp (pair (comp fst fst) (comp snd fst)) f-add)
+  (comp (pair (comp fst snd) (comp snd snd)) f-add))

--- /dev/null
+++ b/hive/f/add3.cammy
@@ -0,0 +1,2 @@
+(pair (comp (pair (comp fst fst) (comp snd fst)) f-add)
+  (comp (pair (comp fst snd) (comp snd snd)) f/add2))

--- /dev/null
+++ b/hive/f/dot2.cammy
@@ -0,0 +1,5 @@
+(comp
+  (pair
+    (comp (pair (comp fst fst) (comp snd fst)) f-mul)
+    (comp (pair (comp fst snd) (comp snd snd)) f-mul))
+  f-add)

--- /dev/null
+++ b/hive/f/dot3.cammy
@@ -0,0 +1,5 @@
+(comp
+  (pair
+    (comp (pair (comp fst fst) (comp snd fst)) f-mul)
+    (comp (pair (comp fst snd) (comp snd snd)) f/dot2))
+  f-add)

--- /dev/null
+++ b/hive/f/euclidean3.cammy
@@ -0,0 +1 @@
+(comp f/sub3 (comp (comp dup f/dot3) f-sqrt))

--- /dev/null
+++ b/hive/f/negate3.cammy
@@ -0,0 +1,2 @@
+(pair (comp fst f-negate)
+  (pair (comp (comp snd fst) f-negate) (comp (comp snd snd) f-negate)))

--- /dev/null
+++ b/hive/f/sqr.cammy
@@ -0,0 +1 @@
+(comp dup f-mul)

--- /dev/null
+++ b/hive/f/sub.cammy
@@ -0,0 +1 @@
+(comp (pair fst (comp snd f-negate)) f-add)

--- /dev/null
+++ b/hive/f/sub3.cammy
@@ -0,0 +1 @@
+(comp (pair fst (comp snd f/negate3)) f/add3)

--- a/movelist/movelist.scm
+++ b/movelist/movelist.scm
@@ -12,14 +12,20 @@
   ; constructors before trivial constructors.
   (conde
     ; Literal s and t.
-    ((== expr 't) (== s 'unit) (== t 'truth))
-    ((== expr 'f) (== s 'unit) (== t 'truth))
-    ((== expr 'not) (== s 'truth) (== t 'truth))
-    ((== expr 'conj) (== s (cons 'truth 'truth)) (== t 'truth))
-    ((== expr 'disj) (== s (cons 'truth 'truth)) (== t 'truth))
+    ((== expr 'conj) (== s (list 'pair 'truth 'truth)) (== t 'truth))
+    ((== expr 'disj) (== s (list 'pair 'truth 'truth)) (== t 'truth))
+    ((== expr 'f-add) (== s (list 'pair 'F 'F)) (== t 'F))
+    ((== expr 'f-mul) (== s (list 'pair 'F 'F)) (== t 'F))
     ; Compound before trivial.
     ((== expr 'succ) (== s 'N) (== t 'N))
     ((== expr 'zero) (== s 'unit) (== t 'N))
+    ((== expr 't) (== s 'unit) (== t 'truth))
+    ((== expr 'f) (== s 'unit) (== t 'truth))
+    ((== expr 'not) (== s 'truth) (== t 'truth))
+    ((== expr 'f-zero) (== s 'unit) (== t 'F))
+    ((== expr 'f-one) (== s 'unit) (== t 'F))
+    ((== expr 'f-negate) (== s 'F) (== t 'F))
+    ((== expr 'f-sqrt) (== s 'F) (== t 'F))
     ; Literal s, recursive t.
     ((fresh (f x y) (== expr (list 'name f))
             (== s 'unit) (== t (list 'hom x y)) (cammyo f x y)))

--- a/shell.nix
+++ b/shell.nix
@@ -8,7 +8,7 @@ in pkgs.stdenv.mkDerivation {
     gdb
     # debugging stub.scm
     chicken rlwrap ] ++
-    (with chickenPackages.chickenEggs; [ srfi-189 mini-kanren ]) ++ [
+    (with chickenPackages.chickenEggs; [ srfi-144 srfi-189 mini-kanren ]) ++ [
     # maintaining frame/
     ocamlformat
     # working with sexps

--- a/stub.scm
+++ b/stub.scm
@@ -1,4 +1,4 @@
-(import (srfi 6) (srfi 189))
+(import (srfi 6) (srfi 144) (srfi 189))
 (import (chicken condition) (chicken format) (chicken process-context) (chicken string))
 (import (matchable))
 
@@ -35,6 +35,13 @@
 (define (fold x f)
   (lambda (l) (if (null? l) (x '()) (f (cons (car l) ((fold x f) (cdr l)))))))
 
+(define f-zero (flonum 0.0))
+(define f-one (flonum 1.0))
+(define (f-negate x) (fl- x))
+(define (f-add xy) (fl+ (car xy) (cdr xy)))
+(define (f-mul xy) (fl* (car xy) (cdr xy)))
+(define (f-sqrt x) (flsqrt x))
+
 (define (read-string s) (read (open-input-string s)))
 (define (arg-error arg why)
   (signal (condition (list 'exn 'message (sprintf "Invalid argument ~A: ~A" arg why)))))
@@ -45,9 +52,10 @@
 (define (arg-nat args) 
   (let ((x (car args)))
     (if (>= x 0) (cons x (cdr args)) (arg-error x "not a natural number"))))
-(define (arg-int args)
+(define (arg-fp args)
   (let ((x (car args)))
-    (if (number? x) (cons x (cdr args)) (arg-error x "not an integer"))))
+    (if (flonum? x) (cons x (cdr args))
+      (arg-error x "not a floating-point number"))))
 (define (arg-pair p1 p2)
   (lambda (args1)
     (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1))
@@ -59,6 +67,7 @@
 
 (define ty-parse (match-lambda
                    ['N arg-nat]
+                   ['F arg-fp]
                    [('pair x y) (arg-pair (ty-parse x) (ty-parse y))]))
 
 (define (cammy-run program ty)