提交: fa414c8aa7290f4490cfa29532906f6e59145fe0 - cammy (git)

A categorical programming language

Commit MetaInfo

• 修订版: fa414c8aa7290f4490cfa29532906f6e59145fe0 (tree)
• 时间: 2022-03-02 14:52:37
• 作者: Corbin <cds@corb...>
• Commiter: Corbin

Log Message

Remove old CHICKEN stub and OCaml frame.

We won't be reusing this code, it hasn't been called in a while, and
it's time for cammy-build to retire, at least for now.

更改概述

• modified: cammy-rpy/weave.py
• delete: cammy.sh
• modified: default.nix
• delete: frame/.ocamlformat
• delete: frame/default.nix
• delete: frame/dune
• delete: frame/dune-project
• delete: frame/frame.ml
• modified: hive/f/10.cammy
• modified: hive/f/1000.cammy
• modified: hive/f/2.cammy
• modified: hive/f/3.cammy
• modified: hive/f/4.cammy
• modified: hive/f/9.cammy
• modified: hive/f/abs.cammy
• modified: hive/f/add2.cammy
• modified: hive/f/add3.cammy
• modified: hive/f/addpair.cammy
• modified: hive/f/approx.cammy
• modified: hive/f/cube.cammy
• modified: hive/f/div.cammy
• modified: hive/f/divpair.cammy
• modified: hive/f/dot2pair.cammy
• modified: hive/f/dot3.cammy
• modified: hive/f/error.cammy
• modified: hive/f/euclidean3.cammy
• modified: hive/f/fract.cammy
• modified: hive/f/half.cammy
• modified: hive/f/ltpair.cammy
• modified: hive/f/min.cammy
• modified: hive/f/minpair.cammy
• modified: hive/f/mulpair.cammy
• modified: hive/f/negate3.cammy
• modified: hive/f/sqr.cammy
• modified: hive/f/sqrt-pos.cammy
• modified: hive/f/sub.cammy
• modified: hive/f/sub3.cammy
• modified: hive/f/subpair.cammy
• modified: hive/f/sum.cammy
• modified: shell.nix
• delete: stub.scm

差异

--- a/cammy-rpy/weave.py
+++ b/cammy-rpy/weave.py
@@ -2,12 +2,16 @@ import os
 import os.path
 import sys
 
+from rpython.rlib.listsort import make_timsort_class
+
 from cammylib.arrows import BuildProblem
 from cammylib.hive import Hive, MissingAtom
 from cammylib.parser import parse
 from cammylib.types import ConstraintStore, TypeExtractor, UnificationFailed
 
 
+SortFileNames = make_timsort_class()
+
 def codeblock(code):
     return "```\n" + code + "\n```"
 
@@ -19,6 +23,7 @@ def main(argv):
     prefix = len(hivepath)
     doc = []
     for dirpath, dirnames, filenames in os.walk(hivepath):
+        SortFileNames(filenames).sort()
         section = dirpath[prefix:] or "Top level"
         doc.append("# " + section)
 

--- a/cammy.sh
+++ /dev/null
@@ -1,40 +0,0 @@
-#!@bash@/bin/bash
-
-# set -x
-set -eu -o pipefail
-
-export CHICKEN_REPOSITORY_PATH=@CHICKEN_REPOSITORY_PATH@
-export CHICKEN_INCLUDE_PATH=@CHICKEN_INCLUDE_PATH@
-
-frame="@frame@/bin/frame"
-jelly="@jelly@/bin/jelly"
-movelist="@movelist@/bin/movelist"
-
-# Configure a temporary directory.
-tmpdir=$(mktemp -d)
-
-# Get the compilation mode, hive, and program to compile.
-mode="$1"
-printf "Compilation mode: %s\n" "$mode"
-hive="$2"
-input="$3"
-
-fullname=$(basename -- $input)
-name="${fullname%.*}"
-
-# Pull from the frame and clarify the jelly.
-<$input $frame $hive | $jelly >"$tmpdir/program.cammy"
-# cat "$tmpdir/program.cammy"
-
-# Typecheck with movelist.
-ty=$($movelist type-check <"$tmpdir/program.cammy")
-printf "Type: %s\n" "$ty"
-
-# Compute the final piece.
-sed -i -e 's,case,cammy-case,g' -e 's,cons,cammy-cons,g' -e 's,map,cammy-map,g' "$tmpdir/program.cammy"
-cat stub.scm <(printf '(cammy-%s' "$1") "$tmpdir/program.cammy" <(echo "'$ty)") >"$tmpdir/$name.scm"
-# Compile with Chicken.
-@chicken@/bin/csc -static -O3 -o "$name" "$tmpdir/$name.scm"
-
-# Clean up temporary files.
-rm -r "$tmpdir"

--- a/default.nix
+++ b/default.nix
@@ -1,7 +1,6 @@
 { nixpkgs ? import <nixpkgs> {} }:
 let
   inherit (nixpkgs) pkgs;
-  frame = import ./frame { inherit nixpkgs; };
   jelly = (import jelly/Cargo.nix { pkgs = nixpkgs; }).rootCrate.build;
   movelist = import ./movelist { inherit nixpkgs; };
   cammy-draw = import ./cammy-rpy/draw.nix { inherit nixpkgs jelly; };
@@ -25,18 +24,11 @@ in pkgs.stdenv.mkDerivation {
   buildInputs = [ pkgs.makeWrapper ];
 
   inherit (pkgs) bash chicken python3;
-  inherit CHICKEN_REPOSITORY_PATH CHICKEN_INCLUDE_PATH frame jelly movelist;
+  inherit CHICKEN_REPOSITORY_PATH CHICKEN_INCLUDE_PATH jelly movelist;
 
   installPhase = ''
     mkdir -p $out/bin/
 
-    substitute $src/cammy.sh $out/bin/cammy-build \
-      --subst-var bash \
-      --subst-var chicken \
-      --subst-var CHICKEN_REPOSITORY_PATH --subst-var CHICKEN_INCLUDE_PATH \
-      --subst-var frame --subst-var jelly --subst-var movelist
-    chmod +x $out/bin/cammy-build
-
     # To be removed
     makeWrapper ${movelist}/bin/movelist $out/bin/cammy-movelist
 

--- a/frame/.ocamlformat
+++ /dev/null
@@ -1 +0,0 @@
-profile=compact

--- a/frame/default.nix
+++ /dev/null
@@ -1,13 +0,0 @@
-{ nixpkgs ? import <nixpkgs> {} }:
-let
-  inherit (nixpkgs.pkgs.ocamlPackages) buildDunePackage sexplib;
-in buildDunePackage {
-  pname = "frame";
-  version = "0.0.1";
-
-  useDune2 = true;
-
-  buildInputs = [ sexplib ];
-
-  src = ./.;
-}

--- a/frame/dune
+++ /dev/null
@@ -1,5 +0,0 @@
-(executable
-    (name frame)
-    (libraries sexplib)
-    (public_name frame)
-    (package frame))

--- a/frame/dune-project
+++ /dev/null
@@ -1,3 +0,0 @@
-(lang dune 2.8)
-(name frame)
-(package (name frame) (synopsis "Recursively expand Cammy programs"))

--- a/frame/frame.ml
+++ /dev/null
@@ -1,76 +0,0 @@
-open Sexplib.Sexp
-module PrimitiveFilter = Set.Make (String)
-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 either \
-   f-zero f-one f-pi \
-   f-sign f-floor f-negate f-recip f-lt f-add f-mul f-sqrt f-sin f-cos f-atan2"
-
-let filter =
-  List.fold_left
-    (Fun.flip PrimitiveFilter.add)
-    PrimitiveFilter.empty
-    (String.split_on_char ' ' primitives)
-
-let which_arg s =
-  let len = String.length s in
-  if len == 0 || s.[0] != '@' then None
-  else int_of_string_opt (String.sub s 1 (len - 1))
-
-let rec arity_of expr =
-  match expr with
-  | Atom a -> Option.fold ~none:0 ~some:(fun x -> x + 1) (which_arg a)
-  | List l -> List.fold_left max 0 (List.rev_map arity_of l)
-
-let is_primitive s =
-  Option.is_some (which_arg s) || PrimitiveFilter.mem s filter
-
-let cache = ref CodeCache.empty
-let basepath = Sys.argv.(1)
-
-let rec apply_functor args expr =
-  match expr with
-  | Atom a -> Option.fold ~none:expr ~some:(List.nth args) (which_arg a)
-  | List l -> List (List.hd l :: List.map (apply_functor args) (List.tl l))
-
-let rec replace_code node =
-  match node with Atom a -> do_atom a | List l -> do_list l
-
-and lookup s =
-  match CodeCache.find_opt s !cache with
-  | Some pair -> pair
-  | None ->
-      let fullpath = Filename.concat basepath s ^ ".cammy" in
-      (* Printf.eprintf "Loading %s...\n" s ; *)
-      let expr = replace_code (load_sexp fullpath) in
-      let arity = arity_of expr in
-      cache := CodeCache.add s (expr, arity) !cache ;
-      (* Printf.eprintf "Loaded %s, arity %d\n" s arity ; *)
-      (expr, arity)
-
-and do_atom s =
-  if is_primitive s then Atom s
-  else
-    let expr, arity = lookup s in
-    if arity != 0 then failwith ("Functor " ^ s ^ " is not nullary") else expr
-
-and do_list l =
-  let tail = List.map replace_code (List.tl l) in
-  let head = List.hd l in
-  match head with
-  | Atom a ->
-      if is_primitive a then List (head :: tail)
-      else
-        let expr, arity = lookup a in
-        if arity != List.length tail then
-          failwith ("Functor " ^ a ^ " misapplied")
-        else apply_functor tail expr
-  | List l -> failwith "Functor heads cannot be lists!"
-
-let tree = input_sexp stdin
-
-let () =
-  output stdout (replace_code tree) ;
-  print_newline ()

--- a/hive/f/10.cammy
+++ b/hive/f/10.cammy
@@ -1 +1,3 @@
 (f/addpair f-one f/9)
+
+Ten.

--- a/hive/f/1000.cammy
+++ b/hive/f/1000.cammy
@@ -1 +1,3 @@
 (comp f/10 f/cube)
+
+One thousand.

--- a/hive/f/2.cammy
+++ b/hive/f/2.cammy
@@ -1 +1,3 @@
 (f/addpair f-one f-one)
+
+Two.

--- a/hive/f/3.cammy
+++ b/hive/f/3.cammy
@@ -1 +1,3 @@
 (f/addpair f-one f/2)
+
+Three.

--- a/hive/f/4.cammy
+++ b/hive/f/4.cammy
@@ -1 +1,3 @@
 (f/addpair f/2 f/2)
+
+Four.

--- a/hive/f/9.cammy
+++ b/hive/f/9.cammy
@@ -1 +1,3 @@
 (comp f/3 f/sqr)
+
+Nine.

--- a/hive/f/abs.cammy
+++ b/hive/f/abs.cammy
@@ -2,3 +2,5 @@
   (pair (comp (comp f-sign either) (case (fun/name id) (fun/name f-negate)))
     id)
   fun/app)
+
+The absolute value of a floating-point number.

--- a/hive/f/add2.cammy
+++ b/hive/f/add2.cammy
@@ -1 +1,3 @@
 (v2/map2 f-add)
+
+Addition of two-dimensional vectors.

--- a/hive/f/add3.cammy
+++ b/hive/f/add3.cammy
@@ -1 +1,3 @@
 (v3/map2 f-add)
+
+Addition of three-dimensional vectors.

--- a/hive/f/addpair.cammy
+++ b/hive/f/addpair.cammy
@@ -1 +1,3 @@
 (comp (pair @0 @1) f-add)
+
+Apply addition to a pair of arrows.

--- a/hive/f/approx.cammy
+++ b/hive/f/approx.cammy
@@ -1,2 +1,5 @@
 (comp (comp (f/error @0) f/sqr)
   (f/ltpair id (fun/const (comp f/1000 f-recip))))
+
+Whether the given functor is approximately equal to the input floating-point
+value at the input parameter. The absolute tolerance is one millionth.

--- a/hive/f/cube.cammy
+++ b/hive/f/cube.cammy
@@ -1 +1,3 @@
 (comp (comp (pair id fun/dup) (pair fst (comp snd f-mul))) f-mul)
+
+The cube of a floating-point number.

--- a/hive/f/div.cammy
+++ b/hive/f/div.cammy
@@ -1 +1,10 @@
 (comp (pair fst (comp snd f-recip)) f-mul)
+
+Divide two floating-point numbers. Division by zero yields:
+
+* $\infty$ for positive dividends
+* $-\infty$ for negative dividends
+* $\pm 0$ for zero dividends
+
+Signs are respected; the result is negative when exactly one input is
+negative, and positive otherwise.

--- a/hive/f/divpair.cammy
+++ b/hive/f/divpair.cammy
@@ -1 +1,3 @@
 (f/mulpair @0 (comp @1 f-recip))
+
+Apply division to a pair of arrows.

--- a/hive/f/dot2pair.cammy
+++ b/hive/f/dot2pair.cammy
@@ -1 +1,3 @@
 (comp (pair @0 @1) f/dot2)
+
+Apply the dot product to a pair of arrows.

--- a/hive/f/dot3.cammy
+++ b/hive/f/dot3.cammy
@@ -1 +1,3 @@
 (comp (v3/map2 f-mul) (v3/fold f-add))
+
+The dot product of two three-dimensional vectors.

--- a/hive/f/error.cammy
+++ b/hive/f/error.cammy
@@ -1 +1,4 @@
 (f/addpair (comp fst @0) (comp snd f-negate))
+
+The error between the output value of the given arrow at the input value and
+the expected input value.

--- a/hive/f/euclidean3.cammy
+++ b/hive/f/euclidean3.cammy
@@ -1 +1,3 @@
 (comp f/sub3 v3/norm)
+
+The Euclidean distance between two three-dimensional vectors.

--- a/hive/f/fract.cammy
+++ b/hive/f/fract.cammy
@@ -1 +1,3 @@
 (f/subpair id (comp f-floor (case id (fun/const f-zero))))
+
+The fractional component of a floating-point number.

--- a/hive/f/half.cammy
+++ b/hive/f/half.cammy
@@ -1 +1,3 @@
 (comp f/2 f-recip)
+
+One half.

--- a/hive/f/ltpair.cammy
+++ b/hive/f/ltpair.cammy
@@ -1 +1,3 @@
 (comp (pair @0 @1) f-lt)
+
+Whether one arrow is less than another at an input value.

--- a/hive/f/min.cammy
+++ b/hive/f/min.cammy
@@ -1 +1,3 @@
 (comp (pair f-lt id) bool/pick)
+
+The minimum of two floating-point numbers.

--- a/hive/f/minpair.cammy
+++ b/hive/f/minpair.cammy
@@ -1 +1,3 @@
 (comp (pair @0 @1) f/min)
+
+The minimum of two arrows at an input value.

--- a/hive/f/mulpair.cammy
+++ b/hive/f/mulpair.cammy
@@ -1 +1,3 @@
 (comp (pair @0 @1) f-mul)
+
+Apply multiplication to a pair of arrows.

--- a/hive/f/negate3.cammy
+++ b/hive/f/negate3.cammy
@@ -1,2 +1,4 @@
 (pair (comp fst f-negate)
   (pair (comp (comp snd fst) f-negate) (comp (comp snd snd) f-negate)))
+
+Negate a three-dimensional vector.

--- a/hive/f/sqr.cammy
+++ b/hive/f/sqr.cammy
@@ -1 +1,3 @@
 (f/mulpair id id)
+
+The square of a floating-point number.

--- a/hive/f/sqrt-pos.cammy
+++ b/hive/f/sqrt-pos.cammy
@@ -1 +1,4 @@
 (comp f-sqrt (case id f-zero))
+
+The square root of a floating-point number, clamped to zero for negative
+inputs.

--- a/hive/f/sub.cammy
+++ b/hive/f/sub.cammy
@@ -1 +1,3 @@
 (comp (pair fst (comp snd f-negate)) f-add)
+
+Subtraction of floating-point numbers.

--- a/hive/f/sub3.cammy
+++ b/hive/f/sub3.cammy
@@ -1 +1,3 @@
 (comp (pair fst (comp snd (v3/map f-negate))) f/add3)
+
+Subtraction of two three-dimensional vectors.

--- a/hive/f/subpair.cammy
+++ b/hive/f/subpair.cammy
@@ -1 +1,3 @@
 (f/addpair @0 (comp @1 f-negate))
+
+Apply subtraction to a pair of arrows.

--- a/hive/f/sum.cammy
+++ b/hive/f/sum.cammy
@@ -1 +1,3 @@
 (fold f-zero f-add)
+
+An uncompensated sum of a list of floating-point numbers.

--- a/shell.nix
+++ b/shell.nix
@@ -10,13 +10,8 @@ in pkgs.stdenv.mkDerivation {
   buildInputs = with pkgs; [
     # debugging native code
     gdb checksec
-    # debugging stub.scm
-    chicken rlwrap ] ++
-    (with eggs; [ srfi-144 srfi-160 srfi-189 stb-image-write ]) ++ [
     # maintaining movelist/
     egg2nix
-    # maintaining frame/
-    ocamlformat
     # maintaining cammy-rpy/
     pythonPackages.pyflakes
     # developing cammy-weave

--- a/stub.scm
+++ /dev/null
@@ -1,162 +0,0 @@
-(import (srfi 6) (srfi 144) (srfi 160 u8) (srfi 189))
-(import (chicken condition) (chicken format) (chicken process-context) (chicken string))
-(import (matchable))
-(import (stb-image-write))
-
-(define id (lambda (x) x))
-(define (comp f g) (lambda (x) (g (f x))))
-
-(define ignore (lambda (x) '()))
-(define fst (lambda (x) (car x)))
-(define snd (lambda (x) (cdr x)))
-(define (pair f g) (lambda (x) (cons (f x) (g x))))
-(define dup (lambda (x) (cons x x)))
-
-(define swap (lambda (x) (cons (cdr x) (car x))))
-
-; left and right are exactly as in SRFI 189
-(define (cammy-case f g) (lambda (x) (either-ref x f g)))
-
-(define (curry f) (lambda (x) (lambda (y) (f (cons x y)))))
-(define (uncurry f) (lambda (xy) ((f (car xy)) (cdr xy))))
-(define (name f) (lambda (x) f))
-
-(define t (lambda (x) #t))
-(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 zero (lambda (x) 0))
-(define succ (lambda (x) (+ x 1)))
-(define (pr x f) (lambda (n) (if (zero? n) (x '()) (f ((pr x f) (- n 1))))))
-
-(define nil (lambda (x) '()))
-(define cammy-cons (lambda (xy) (cons (car xy) (cdr xy))))
-(define (cammy-map f) (lambda (l) (map f l)))
-(define (fold x f)
-  (lambda (l) (if (null? l) (x '()) (f (cons (car l) ((fold x f) (cdr l)))))))
-
-(define f-zero (lambda (x) (flonum 0.0)))
-(define f-one (lambda (x) (flonum 1.0)))
-(define f-sign (lambda (x) (eqv? (flsign-bit x) 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)))
-(define (f-sqrt x) (if (eqv? 0 (flsign-bit x)) (left (flsqrt x)) (right '())))
-
-(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)))))
-(define (arg-unit args) (cons '() args))
-(define (arg-bool args)
-  (let ((x (car args)))
-    (if (boolean? x) (cons x (cdr args)) (arg-error x "not bool"))))
-(define (arg-nat args) 
-  (let ((x (car args)))
-    (if (>= x 0) (cons x (cdr args)) (arg-error x "not a natural number"))))
-(define (arg-fp args)
-  (let ((x (car args)))
-    (if (flonum? x) (cons x (cdr args))
-      (arg-error x "not a floating-point number"))))
-(define (arg-list p)
-  (lambda (args)
-    (let ((x (car args)))
-      (cons x (cdr args)))))
-(define (arg-pair p1 p2)
-  (lambda (args1)
-    (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1))
-           (pair2 (p2 args2)) (y (car pair2)) (args3 (cdr pair2)))
-      (cons (cons x y) args3))))
-
-(define (argv) (map read-string (command-line-arguments)))
-
-(define (parse-args parser)
-  (parser (argv)))
-
-(define ty-parse (match-lambda
-                   ['1 arg-unit]
-                   ['N arg-nat]
-                   ['F arg-fp]
-                   [('list x) (arg-list (ty-parse x))]
-                   [('pair x y) (arg-pair (ty-parse x) (ty-parse y))]))
-
-; Run a program once using argv for parameters.
-(define (cammy-oneshot program ty)
-  (let*
-    ((input (car (parse-args (ty-parse (car ty)))))
-     (rv (program input)))
-    (begin (display rv) (newline))))
-
-
-(define (scale bot top)
-  (let ((d (- top bot)))
-    (lambda (x) (+ bot (* d x)))))
-
-(define (viewport window width height)
-  (let*
-    ((aspect (/ width height))
-     (iw (/ width))
-     (ih (/ height))
-     (dw (* 0.5 iw))
-     (dh (* 0.5 ih))
-     (sw (scale (car window) (car (cdr (cdr window)))))
-     (sh (scale (car (cdr window)) (car (cdr (cdr (cdr window)))))))
-    (lambda (i)
-      (let ((w (modulo i width)) (h (/ i width)))
-        (cons (sw (+ dw (* iw w))) (sh (+ dh (* ih h))))))))
-
-(define f-sum (fold f-zero f-add))
-(define (f-average xs) (/ (f-sum xs) (length xs)))
-
-(define ((multisample radius program) p)
-  (let*
-    ((px (car p))
-     (py (cdr p))
-     (c0 (program p))
-     (c1 (program (cons (+ px radius) py)))
-     (c2 (program (cons (- px radius) py)))
-     (c3 (program (cons px (+ py radius))))
-     (c4 (program (cons px (- py radius))))
-     (l (list c0 c1 c2 c3 c4))
-     (red (f-average (map car l)))
-     (blue (f-average (map (comp cdr car) l)))
-     (green (f-average (map (comp cdr cdr) l))))
-    (cons red (cons blue green))))
-
-(define (finish-channel c)
-  (inexact->exact (round (* 255 (max 0.0 (min 1.0 c))))))
-
-(define ((draw-pixel program vp) i)
-  (let*
-    ((color (program (vp i)))
-     (r (car color))
-     (g (car (cdr color)))
-     (b (cdr (cdr color))))
-    (list->u8vector (map finish-channel (list r g b)))))
-
-(define (draw-png program filename window width height)
-  (let*
-    ((vp (viewport window width height))
-     (size (* width height))
-     (radius 0.000001)
-     (channels 3)
-     (drawable (draw-pixel (multisample radius program) vp))
-     ; (drawable (draw-pixel program vp))
-     (pixels
-       (do ((buf (make-u8vector (* size channels)))
-            (i 0 (+ i 1)))
-         ((eqv? i size) buf)
-         (u8vector-copy! buf (* i channels) (drawable i)))))
-    (with-output-to-file filename
-                         (lambda () (write-png pixels width height
-                                               channels)))))
-
-; Run a program repeatedly and draw the results.
-(define (cammy-draw program ty)
-  (match (command-line-arguments)
-         [(window width height filename)
-          (draw-png program filename (read-string window) (read-string width)
-                    (read-string height))]))