Commit: bb980a9488cc1866b3be9f784be7722bcb8f4795 - cammy (git)

A categorical programming language

Commit MetaInfo

• Revisión: bb980a9488cc1866b3be9f784be7722bcb8f4795 (tree)
• Tiempo: 2021-09-30 07:25:05
• Autor: Corbin <cds@corb...>
• Commiter: Corbin

Log Message

Fix up float functions, raytrace a cubic function.

Cambiar Resumen

• modified: frame/frame.ml
• add: hive/f/10.cammy
• add: hive/f/1000.cammy
• add: hive/f/2.cammy
• add: hive/f/3.cammy
• add: hive/f/9.cammy
• add: hive/f/approx.cammy
• add: hive/f/cube.cammy
• add: hive/f/error.cammy
• add: hive/nat/cube.cammy
• modified: movelist/movelist.scm
• modified: stub.scm

Diferencia incremental

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

--- /dev/null
+++ b/hive/f/10.cammy
@@ -0,0 +1 @@
+(comp (pair f-one f/9) f-add)

--- /dev/null
+++ b/hive/f/1000.cammy
@@ -0,0 +1 @@
+(comp f/10 f/cube)

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

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

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

--- /dev/null
+++ b/hive/f/approx.cammy
@@ -0,0 +1,2 @@
+(comp (comp (f/error @0) f/sqr)
+  (comp (pair id (comp ignore (comp f/1000 f-recip))) f-lt))

--- /dev/null
+++ b/hive/f/cube.cammy
@@ -0,0 +1 @@
+(comp (comp (pair id fun/dup) (pair fst (comp snd f-mul))) f-mul)

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

--- /dev/null
+++ b/hive/nat/cube.cammy
@@ -0,0 +1 @@
+(comp (comp fun/dup (pair fst (comp snd nat/sqr))) nat/mul)

--- a/movelist/movelist.scm
+++ b/movelist/movelist.scm
@@ -14,6 +14,7 @@
     ; Literal s and t.
     ((== expr 'conj) (== s (list 'pair '2 '2)) (== t '2))
     ((== expr 'disj) (== s (list 'pair '2 '2)) (== t '2))
+    ((== expr 'either) (== s '2) (== t (list 'sum '1 '1)))
     ((== expr 'f-lt) (== s (list 'pair 'F 'F)) (== t '2))
     ((== expr 'f-add) (== s (list 'pair 'F 'F)) (== t 'F))
     ((== expr 'f-mul) (== s (list 'pair 'F 'F)) (== t 'F))
@@ -27,6 +28,7 @@
     ((== expr 'f-zero) (== s '1) (== t 'F))
     ((== expr 'f-one) (== s '1) (== t 'F))
     ((== expr 'f-negate) (== s 'F) (== t 'F))
+    ((== expr 'f-recip) (== s 'F) (== t 'F))
     ; Literal s, recursive t.
     ((fresh (x f) (== expr (list 'pr x f))
             (== s 'N) (cammyo x '1 t) (cammyo f t t)))

--- a/stub.scm
+++ b/stub.scm
@@ -26,6 +26,7 @@
 (define f (lambda (x) #f))
 (define conj (lambda (xy) (and (car xy) (cdr xy))))
 (define disj (lambda (xy) (or (car xy) (cdr xy))))
+(define either (lambda (b) (if b (left '()) (right '()))))
 (define pick (lambda (bxy)
                (let ((xy (cdr bxy)))
                  (if (car bxy) (car xy) (cdr xy)))))
@@ -43,6 +44,7 @@
 (define f-zero (lambda (x) (flonum 0.0)))
 (define f-one (lambda (x) (flonum 1.0)))
 (define (f-negate x) (fl- x))
+(define (f-recip x) (fl/ x))
 (define (f-lt xy) (fl<? (car xy) (cdr xy)))
 (define (f-add xy) (fl+ (car xy) (cdr xy)))
 (define (f-mul xy) (fl* (car xy) (cdr xy)))
@@ -78,6 +80,7 @@
   (parser (argv)))
 
 (define ty-parse (match-lambda
+                   ['1 arg-unit]
                    ['N arg-nat]
                    ['F arg-fp]
                    [('list x) (arg-list (ty-parse x))]