提交: b2de512f08a1218800abe9e93879609a5c747c8f - cammy (git)

A categorical programming language

Commit MetaInfo

• 修订版: b2de512f08a1218800abe9e93879609a5c747c8f (tree)
• 时间: 2021-11-04 10:00:26
• 作者: Corbin <cds@corb...>
• Commiter: Corbin

Log Message

Graph complex functions with standard coloration.

更改概述

• modified: cammy-run/default.nix
• modified: cammy-run/main.py
• modified: frame/frame.ml
• add: hive/complex-graph.cammy
• add: hive/f/fract.cammy
• add: hive/h2rgb.cammy
• add: hive/hv2rgb.cammy
• add: hive/nat/to-f.cammy
• add: hive/v3/broadcast.cammy
• modified: movelist/movelist.scm

差异

--- a/cammy-run/default.nix
+++ b/cammy-run/default.nix
@@ -30,7 +30,7 @@ stdenv.mkDerivation {
     cp -r ${pypySrc}/rpython .
     chmod -R u+w rpython/
     # Do the actual translation.
-    ${pypy}/bin/pypy -mrpython -Ojit main.py
+    ${pypy}/bin/pypy -mrpython -O2 main.py
     '';
 
   installPhase = ''

--- a/cammy-run/main.py
+++ b/cammy-run/main.py
@@ -13,6 +13,7 @@ import math, sys
 from rpython.rlib.jit import JitDriver, set_param
 from rpython.rlib.parsing.main import make_parser_from_file
 from rpython.rlib.parsing.tree import RPythonVisitor
+from rpython.rlib.rbigint import rbigint
 from rpython.rlib.rfile import create_stdio
 from rpython.rlib.rfloat import string_to_float
 from rpython.rlib.rstring import StringBuilder, split
@@ -55,6 +56,14 @@ class B(Element):
     def b(self):
         return self._b
 
+class N(Element):
+    _immutable_ = True
+    def __init__(self, bi):
+        self._bi = bi
+
+    def n(self):
+        return self._bi
+
 class F(Element):
     _immutable_ = True
 
@@ -177,6 +186,28 @@ class Either(Arrow):
     def run(self, x):
         return L(T()) if x.b() else R(T())
 
+class Zero(Arrow):
+    _immutable_ = True
+    def run(self, x): return N(rbigint.fromint(0))
+
+class Succ(Arrow):
+    _immutable_ = True
+    def run(self, x): return N(x.n().int_add(1))
+
+class PrimRec(Arrow):
+    _immutable_ = True
+    def __init__(self, x, f):
+        self._x = x
+        self._f = f
+
+    def run(self, x):
+        n = x.n()
+        rv = self._x.run(T())
+        while n.tobool():
+            n = n.int_sub(1)
+            rv = self._f.run(rv)
+        return rv
+
 class FZero(Arrow):
     _immutable_ = True
     def run(self, x): return F(0.0)
@@ -194,6 +225,14 @@ class FSign(Arrow):
     _immutable_ = True
     def run(self, x): return B(sign(x.f()))
 
+class FFloor(Arrow):
+    _immutable_ = True
+    def run(self, x):
+        try:
+            return L(F(float(math.floor(x.f()))))
+        except (ValueError, OverflowError):
+            return R(T())
+
 class FNegate(Arrow):
     _immutable_ = True
     def run(self, x): return F(-x.f())
@@ -251,10 +290,13 @@ unaryFunctors = {
     "left": Left(),
     "right": Right(),
     "either": Either(),
+    "zero": Zero(),
+    "succ": Succ(),
     "f-zero": FZero(),
     "f-one": FOne(),
     "f-pi": FPi(),
     "f-sign": FSign(),
+    "f-floor": FFloor(),
     "f-negate": FNegate(),
     "f-recip": FRecip(),
     "f-lt": FLT(),
@@ -281,6 +323,8 @@ def buildCompound(name, args):
         return Curry(args[0])
     elif name == "uncurry" and len(args) == 1:
         return Uncurry(args[0])
+    elif name == "pr" and len(args) == 2:
+        return PrimRec(args[0], args[1])
     else:
         raise BuildProblem("Invalid compound functor: " + name)
 

--- a/frame/frame.ml
+++ b/frame/frame.ml
@@ -6,7 +6,7 @@ let primitives =
   "id comp ignore fst snd pair left right case curry uncurry \
    zero succ pr nil cons fold t f not conj disj either \
    f-zero f-one f-pi \
-   f-sign f-negate f-recip f-lt f-add f-mul f-sqrt f-atan2"
+   f-sign f-floor f-negate f-recip f-lt f-add f-mul f-sqrt f-atan2"
 
 let filter =
   List.fold_left

--- /dev/null
+++ b/hive/complex-graph.cammy
@@ -0,0 +1,9 @@
+(comp
+  (pair
+    (f/addpair
+      (f/divpair
+        (comp fun/swap f-atan2)
+        (fun/const (f/mulpair f-pi f/2)))
+      (comp f/2 f-recip))
+    v2/norm)
+  hv2rgb)

--- /dev/null
+++ b/hive/f/fract.cammy
@@ -0,0 +1 @@
+(f/subpair id (comp f-floor (case id (fun/const f-zero))))

--- /dev/null
+++ b/hive/h2rgb.cammy
@@ -0,0 +1,14 @@
+(comp
+  (comp
+    (pair
+      (v3/broadcast id)
+      (fun/const (v3/triple f-one (f/divpair f/2 f/3) (comp f/3 f-recip))))
+    (v3/map2 f-add))
+  (v3/map 
+    (f/subpair
+      (comp
+        (f/subpair 
+          (f/mulpair f/fract (fun/const (f/mulpair f/2 f/3)))
+          (fun/const f/3))
+        f/abs)
+      (fun/const f-one))))

--- /dev/null
+++ b/hive/hv2rgb.cammy
@@ -0,0 +1,3 @@
+(comp
+  (pair (comp fst h2rgb) (v3/broadcast snd))
+  (v3/map2 f-mul))

--- /dev/null
+++ b/hive/nat/to-f.cammy
@@ -0,0 +1 @@
+(pr f-zero (f/addpair id (fun/const f-one)))

--- /dev/null
+++ b/hive/v3/broadcast.cammy
@@ -0,0 +1 @@
+(v3/triple @0 @0 @0)

--- a/movelist/movelist.scm
+++ b/movelist/movelist.scm
@@ -19,6 +19,7 @@
     ((== expr 'f-add) (== s (list 'pair 'F 'F)) (== t 'F))
     ((== expr 'f-mul) (== s (list 'pair 'F 'F)) (== t 'F))
     ((== expr 'f-sqrt) (== s 'F) (== t (list 'sum 'F '1)))
+    ((== expr 'f-floor) (== s 'F) (== t (list 'sum 'F '1)))
     ((== expr 'f-atan2) (== s (list 'pair 'F 'F)) (== t 'F))
     ; Compound before trivial.
     ((== expr 'succ) (== s 'N) (== t 'N))