• R/O
  • HTTP
  • SSH
  • HTTPS

提交

标签
No Tags

Frequently used words (click to add to your profile)

javaandroidc++linuxc#windowsobjective-ccocoaqt誰得pythonphprubygameguibathyscaphec計画中(planning stage)翻訳omegatframeworktwitterdomtestvb.netdirectxゲームエンジンbtronarduinopreviewer

A categorical programming language


Commit MetaInfo

修订版6165ec9b2c325d1662942ff286c5402ca7dd473a (tree)
时间2021-09-17 02:56:17
作者Corbin <cds@corb...>
CommiterCorbin

Log Message

Add Choice for Booleans.

This does not restrain the target category much; we are only saying that

2 = 1 + 1

Which is relatively standard for sums.

更改概述

差异

--- a/frame/frame.ml
+++ b/frame/frame.ml
@@ -4,7 +4,7 @@ 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 pr 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 pick \
88 f-zero f-one f-negate f-add f-mul f-sqrt"
99
1010 let filter =
--- /dev/null
+++ b/hive/list/evens.cammy
@@ -0,0 +1,2 @@
1+(comp list/range
2+ (fold nil (comp (pair (comp fst nat/is_even) (pair cons snd)) pick)))
--- /dev/null
+++ b/hive/nat/iter.cammy
@@ -0,0 +1 @@
1+(pr (name id) (curry app))
--- a/movelist/movelist.scm
+++ b/movelist/movelist.scm
@@ -14,8 +14,10 @@
1414 ; Literal s and t.
1515 ((== expr 'conj) (== s (list 'pair '2 '2)) (== t '2))
1616 ((== expr 'disj) (== s (list 'pair '2 '2)) (== t '2))
17+ ((== expr 'f-lt) (== s (list 'pair 'F 'F)) (== t '2))
1718 ((== expr 'f-add) (== s (list 'pair 'F 'F)) (== t 'F))
1819 ((== expr 'f-mul) (== s (list 'pair 'F 'F)) (== t 'F))
20+ ((== expr 'f-sqrt) (== s 'F) (== t (list 'sum 'F '1)))
1921 ; Compound before trivial.
2022 ((== expr 'succ) (== s 'N) (== t 'N))
2123 ((== expr 'zero) (== s '1) (== t 'N))
@@ -25,12 +27,12 @@
2527 ((== expr 'f-zero) (== s '1) (== t 'F))
2628 ((== expr 'f-one) (== s '1) (== t 'F))
2729 ((== expr 'f-negate) (== s 'F) (== t 'F))
28- ((== expr 'f-sqrt) (== s 'F) (== t (list 'sum 'F '1)))
2930 ; Literal s, recursive t.
3031 ((fresh (f x y) (== expr (list 'name f))
3132 (== s '1) (== t (list 'hom x y)) (cammyo f x y)))
3233 ((fresh (x f) (== expr (list 'pr x f))
3334 (== s 'N) (cammyo x '1 t) (cammyo f t t)))
35+ ((== expr 'pick) (== s (list 'pair '2 (list 'pair t t))))
3436 ; Parametric polymorphism with structural recursion on both sides.
3537 ((== expr 'swap) (fresh (x y) (== s (list 'pair x y)) (== t (list 'pair y x))))
3638 ((== expr 'assl)
--- a/stub.scm
+++ b/stub.scm
@@ -25,6 +25,9 @@
2525 (define f (lambda (x) #f))
2626 (define conj (lambda (xy) (and (car xy) (cdr xy))))
2727 (define disj (lambda (xy) (or (car xy) (cdr xy))))
28+(define pick (lambda (bxy)
29+ (let ((xy (cdr bxy)))
30+ (if (car bxy) (car xy) (cdr xy)))))
2831
2932 (define zero (lambda (x) 0))
3033 (define succ (lambda (x) (+ x 1)))
@@ -39,6 +42,7 @@
3942 (define f-zero (flonum 0.0))
4043 (define f-one (flonum 1.0))
4144 (define (f-negate x) (fl- x))
45+(define (f-lt xy) (fl<? (car xy) (cdr xy)))
4246 (define (f-add xy) (fl+ (car xy) (cdr xy)))
4347 (define (f-mul xy) (fl* (car xy) (cdr xy)))
4448 (define (f-sqrt x) (if (eqv? 0 (flsign-bit x)) (left (flsqrt x)) (right '())))