• R/O
  • HTTP
  • SSH
  • HTTPS

提交

标签
No Tags

Frequently used words (click to add to your profile)

javac++androidlinuxc#windowsobjective-cqtcocoa誰得pythonphprubygameguibathyscaphec翻訳計画中(planning stage)omegatframeworktwittertestdomvb.netdirectxbtronarduinopreviewerゲームエンジン

A categorical programming language


Commit MetaInfo

修订版ebd7182e841cb0cda535c8f84eaf0383d14a2130 (tree)
时间2021-09-16 08:38:09
作者Corbin <cds@corb...>
CommiterCorbin

Log Message

Add initial floating-point support.

更改概述

差异

--- a/frame/frame.ml
+++ b/frame/frame.ml
@@ -4,7 +4,8 @@ module CodeCache = Map.Make (String)
44
55 let primitives =
66 "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"
89
910 let filter =
1011 List.fold_left
--- /dev/null
+++ b/hive/f/add2.cammy
@@ -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))
--- /dev/null
+++ b/hive/f/add3.cammy
@@ -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))
--- /dev/null
+++ b/hive/f/dot2.cammy
@@ -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)
--- /dev/null
+++ b/hive/f/dot3.cammy
@@ -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)
--- /dev/null
+++ b/hive/f/euclidean3.cammy
@@ -0,0 +1 @@
1+(comp f/sub3 (comp (comp dup f/dot3) f-sqrt))
--- /dev/null
+++ b/hive/f/negate3.cammy
@@ -0,0 +1,2 @@
1+(pair (comp fst f-negate)
2+ (pair (comp (comp snd fst) f-negate) (comp (comp snd snd) f-negate)))
--- /dev/null
+++ b/hive/f/sqr.cammy
@@ -0,0 +1 @@
1+(comp dup f-mul)
--- /dev/null
+++ b/hive/f/sub.cammy
@@ -0,0 +1 @@
1+(comp (pair fst (comp snd f-negate)) f-add)
--- /dev/null
+++ b/hive/f/sub3.cammy
@@ -0,0 +1 @@
1+(comp (pair fst (comp snd f/negate3)) f/add3)
--- a/movelist/movelist.scm
+++ b/movelist/movelist.scm
@@ -12,14 +12,20 @@
1212 ; constructors before trivial constructors.
1313 (conde
1414 ; 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))
2019 ; Compound before trivial.
2120 ((== expr 'succ) (== s 'N) (== t 'N))
2221 ((== 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))
2329 ; Literal s, recursive t.
2430 ((fresh (f x y) (== expr (list 'name f))
2531 (== 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 {
88 gdb
99 # debugging stub.scm
1010 chicken rlwrap ] ++
11- (with chickenPackages.chickenEggs; [ srfi-189 mini-kanren ]) ++ [
11+ (with chickenPackages.chickenEggs; [ srfi-144 srfi-189 mini-kanren ]) ++ [
1212 # maintaining frame/
1313 ocamlformat
1414 # working with sexps
--- a/stub.scm
+++ b/stub.scm
@@ -1,4 +1,4 @@
1-(import (srfi 6) (srfi 189))
1+(import (srfi 6) (srfi 144) (srfi 189))
22 (import (chicken condition) (chicken format) (chicken process-context) (chicken string))
33 (import (matchable))
44
@@ -35,6 +35,13 @@
3535 (define (fold x f)
3636 (lambda (l) (if (null? l) (x '()) (f (cons (car l) ((fold x f) (cdr l)))))))
3737
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+
3845 (define (read-string s) (read (open-input-string s)))
3946 (define (arg-error arg why)
4047 (signal (condition (list 'exn 'message (sprintf "Invalid argument ~A: ~A" arg why)))))
@@ -45,9 +52,10 @@
4552 (define (arg-nat args)
4653 (let ((x (car args)))
4754 (if (>= x 0) (cons x (cdr args)) (arg-error x "not a natural number"))))
48-(define (arg-int args)
55+(define (arg-fp args)
4956 (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"))))
5159 (define (arg-pair p1 p2)
5260 (lambda (args1)
5361 (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1))
@@ -59,6 +67,7 @@
5967
6068 (define ty-parse (match-lambda
6169 ['N arg-nat]
70+ ['F arg-fp]
6271 [('pair x y) (arg-pair (ty-parse x) (ty-parse y))]))
6372
6473 (define (cammy-run program ty)