Re-namespacing

Moving away from the DNS-driven namespacing toward more condensed names,
mostly because I don't like typing so much.

6 files changed, 493 insertions, 0 deletions

diff --git a/Alpha/Core.scm b/Alpha/Core.scm
new file mode 100644
index 0000000..3a5ac6e
--- /dev/null
+++ b/Alpha/Core.scm
@@ -0,0 +1,158 @@
+(define-module (Alpha Core)
+  #:use-module ((ice-9 format))
+  #:export (
+            ;; simple printing
+            fmt printf pr prn
+
+                ;; navigating data
+            first next second rest
+
+            ;; booleans
+            true? false? nil nil?
+
+            ;; dev helpers
+            comment
+            ))
+
+(define (flip f)           (lambda (x y) (f y x)))
+(define (curry f a)        (lambda (b) (apply f (cons a (list b)))))
+(define pos?
+  (curry < 0))
+
+(define neg?
+  (curry > 0))
+
+(define (foldr f end lst)
+  (if (null? lst)
+    end
+    (f (car lst) (foldr f end (cdr lst)))))
+
+(define (foldl f acc lst)
+  (if (null? lst)
+    acc
+    (foldl f (f acc (car lst)) (cdr lst))))
+
+(define fold foldl)
+
+(define (unfold f init pred)
+  (if (pred init)
+    (cons init '())
+    (cons init (unfold f (f init) pred))))
+
+(define (sum lst)          (fold + 0 lst))
+(define (produce lst)      (fold * 1 lst))
+
+(define count length)
+
+
+;;
+;; clojure-like stuff
+;;
+
+(define (pr . a)
+  (for-each display a))
+
+(define (prn . a) (apply pr a) (newline))
+
+(define (first a)
+  "Return the first item in the collection."
+  (car a))
+
+(define (rest a)
+  "Returns a list of the items after the first."
+  (cdr a))
+
+(define (next a)
+  "Returns the next item after the first."
+  (cadr a))
+
+;; same thing, easier to remember/read
+(define second next)
+
+(define (ffirst a)
+  (first (first a)))
+
+(define (nnext a)
+  (next (next a)))
+
+(define (last coll)
+  "Return the last time in coll, in linear time."
+  (if (next coll)
+      (last coll)
+      (first coll)))
+
+(define (butlast ls)
+  "Return everthing execpt the last element in ls."
+  (let ((len (length ls)))
+    (list-head ls (- len 1))))
+
+(define (false? x)
+  (eq? #f x))
+
+(define (true? x)
+  (eq? #t x))
+
+(define nil #nil)
+
+(define (nil? x)
+  (eq? nil x))
+
+;; Ignores body, returns nil.
+(define-syntax comment
+  (syntax-rules ()
+    ((_ ...) nil)))
+
+(comment
+ ;; nil is different from null. nil is supposed to be more like
+ ;; 'Nothing' in Haskell, it is the absence of any value or type;
+ ;; whereas null is specifically the empty list, which still has a type
+ ;; of 'list'.
+ (null? '()) ;; => #t
+ (nil? '())  ;; => #f
+ )
+
+(define (some pred coll)
+  (or (pred (first coll))
+      (some pred (next coll))))
+
+(define comp compose)
+
+(define (not-any? pred coll)
+  (comp not some))
+
+(define (printf . args)
+  (display (apply format args)))
+
+(define-syntax fmt
+  (syntax-rules ()
+    ((_ s args ...)
+     (format #f s args ...))))
+
+;; If I implement ML-like interface abstractions in scheme, what would it look like?
+
+;; 
+;; ;; seq
+
+;; (define-class <seq> () (_first))
+
+;; 
+;; ;; Functor
+
+;; (define-class <functor> ())
+
+;; (define-method (fmap (f <procedure>) (coll <functor>)))
+
+;; 
+;; ;; Applicative
+
+;; ;; a -> f a
+;; (define-method (pure (a <any>)))
+
+;; ;; f (a -> b) -> f a -> f b
+;; (define-method (<*> (f <procedure>) (a <applicative>) (b <applicative>)))
+
+;; ;; f a -> f b -> f b
+;; (define-method (*> (a <applicative>) (b <applicative>)))
+
+;; ;; f a -> f b -> f a
+;; (define-method (<* (a <applicative>) (b <applicative>)))
diff --git a/Alpha/Logic.scm b/Alpha/Logic.scm
new file mode 100644
index 0000000..e438a03
--- /dev/null
+++ b/Alpha/Logic.scm
@@ -0,0 +1,238 @@
+;; my mini kanren impl - basically untested so far
+
+(define-module (Alpha Logic))
+
+(define-syntax λg
+  (syntax-rules ()
+    ((_ (s) e) (lambda (s) e))))
+
+(define-syntax λf
+  (syntax-rules ()
+    ((_ () e) (lambda () e))))
+
+(define (unify u v s)
+  (let ([u (walk u s)]
+        [v (walk v s)])
+    (cond
+     [(eq? u u) s]
+
+     [(var? u)
+      (cond
+       [(var? v) (ext-s-check u v s)]
+       [else (ext-s-check u v s)])]
+
+     [(and (pair? u) (pair? v))
+      (let ([s (unify (car u) (car v) s)])
+        (and s (unify (cdr u) (cdr v) s)))]
+
+     [(equal? u v) s]
+
+     [else #f])))
+
+(define-syntax if-not
+  (syntax-rules ()
+    ((_ pred then else)
+     (if (not pred) then else))))
+
+(define (walk v s)
+  (if-not (var? v)
+      v
+    (let ([a (assq v s)])
+      (if a
+          (walk (cdr a) s)
+          v))))
+
+(define (ext-s-check x v s)
+  (if-not (occurs-check x v s)
+      (ext-s x v s)
+    #f))
+
+(define (occurs-check x v s)
+  (let ([v (walk v s)])
+    (cond
+     [(var? v) (eq? v x)]
+     [(pair? v)
+      (or (occurs-check x (car v) s)
+          (occurs-check x (cdr v) s))]
+     [else #f])))
+
+(define (ext-s x v s)
+  (cons `(,x . ,v) s))
+
+(define empty-s '())
+
+(define var vector)
+(define var? vector?)
+
+(define reify
+  (letrec ([reify-s (lambda [v s]
+                      (let ([v (walk v s)])
+                        (cond
+                         [(var? v) (ext-s v (reify-name (length s)) s)]
+                         [(pair? v) (reify-s (cdr v) (reify-s (car v) s))]
+                         [else s])))])
+    (lambda [v s]
+      (let ([v (walk* v s)])
+        (walk* v (reify-s v empty-s))))))
+
+(define walk*
+  (lambda [w s]
+    (let ([v (walk w s)])
+      (cond
+       [(var? v) v]
+       [(pair? v) (cons (walk* (car v) s)
+                        (walk* (cdr v) s))]
+       [else v]))))
+
+(define reify-name
+  (lambda [n]
+    (string->symbol
+     (string-append "_" "." (number->string n)))))
+
+(define-syntax mzero
+  (syntax-rules ()
+    ((_) #f)))
+
+(define-syntax unit
+  (syntax-rules ()
+    ((_ a) a)))
+
+(define-syntax choice
+  (syntax-rules ()
+    ((_ a f) (cons a f))))
+
+(define-syntax inc
+  (syntax-rules ()
+    ((_ e) (λf () e))))
+
+(define-syntax case-inf
+  (syntax-rules ()
+    ((_ e on-zero
+        [(a^) on-one]
+        [(a f) on-choice]
+        [(f^) on-inc])
+     (let ([a-inf e])
+       (cond
+        ;; a-inf = #f
+        [(not a-inf) on-zero]
+        ;; a-inf = lambda
+        [(procedure? a-inf) (let ((f^ a-inf)) on-inc)]
+        ;; a-inf = (x . lambda)
+        [(and (pair? a-inf) (procedure? (cdr a-inf)))
+         (let ([a (car a-inf)]
+               [f (cdr a-inf)])
+           on-choice)]
+        [else (let ((a^ a-inf)) on-one)])))))
+
+(define-syntax ==
+  (syntax-rules ()
+    ((_ u v)
+     (λg (s) (unify u v s)))))
+
+(define-syntax conde
+  (syntax-rules ()
+    ((_ (g0 g ...) (g1 g^ ...) ...)
+     (λg (s)
+         (inc (mplus*
+               (bind* (g0 s) g ...)
+               (bind* (g1 s) g^ ...) ...))))))
+
+(define-syntax mplus*
+  (syntax-rules ()
+    ((_ e) e)
+    ((_ e0 e ...) (mplus e0 (λf () (mplus* e ...))))))
+
+(define mplus
+  (lambda (a-inf f)
+    (case-inf a-inf (f)
+              ((a) (choice a f))
+              ((a f^) (choice a (λf () (mplus (f) f^))))
+              ((f^) (inc (mplus (f) f^))))))
+
+(define-syntax fresh
+  (syntax-rules ()
+    ((_ (x ...) g0 g ...)
+     (λg (s)
+         (let ((x (var 'x)) ...)
+           (bind* (g0 s) g ...))))))
+
+(define-syntax bind*
+  (syntax-rules ()
+    ((_ e) e)
+    ((_ e g0 g ...)
+     (let ((a-inf e))
+       (and a-inf (bind* (bind a-inf g0) g ...))))))
+
+(define bind
+  (lambda (a-inf g)
+    (case-inf a-inf (mzero)
+              ((a) (g a))
+              ((a f) (mplus (g a) (λf () (bind (f) g))))
+              ((f) (inc (bind (f) g))))))
+
+(define-syntax run
+  (syntax-rules ()
+    ((_ n (x) g0 g^ ...)
+     (take n
+           (λf
+            ()
+            (let ((g (fresh
+                      (x)
+                      (λg
+                       (s)
+                       (bind* (g0 s) g^ ...
+                              (λg (s)
+                                  (list (reify x s))))))))
+              (g empty-s)))))))
+
+(define-syntax run*
+  (syntax-rules ()
+    ((_ (x) g ...) (run #f (x) g ...))))
+
+(define take
+  (lambda (n f)
+    (if (and n (zero? n))
+        '()
+        (case-inf (f) '()
+         [(a) a]
+         [(a f) (cons (car a) (take (and n (- n 1)) f))]
+         [(f) (take n f)]))))
+
+(define-syntax conda
+  (syntax-rules ()
+    ((_ (g0 g ...) (g1 g^ ...) ...)
+     (λg (s)
+         (if* (picka (g0 s) g ...) (picka (g1 s) g^ ...) ...)))))
+
+(define-syntax condu
+  (syntax-rules ()
+    ((_ (g0 g ...) (g1 g^ ...) ...)
+     (λg (s)
+         (if* (picku (g0 s) g ...)
+              (picku (g1 s) g^ ...)
+              ...)))))
+
+(define-syntax if*
+  (syntax-rules ()
+    ((_) (mzero))
+    ((_ (pick e g ...) b ...)
+     (let loop ((a-inf e))
+       (case-inf a-inf (if* b ...)
+                 [(a) (bind* a-inf g ...)]
+                 [(a f) (bind* (pick a a-inf) g ...)]
+                 [(f) (inc (loop (f)))])))))
+
+(define-syntax picka
+  (syntax-rules ()
+    ((_ a a-inf) a-inf)))
+
+(define-syntax picku
+  (syntax-rules ()
+    ((_ a a-inf) (unit a))))
+
+(define-syntax project
+  (syntax-rules ()
+    ((_ (x ...) g0 g ...)
+     (λg (s)
+         (let ((x (walk* x s)) ...)
+           (bind* (g0 s) g ...))))))
diff --git a/Alpha/Repl.scm b/Alpha/Repl.scm
new file mode 100644
index 0000000..f2d9160
--- /dev/null
+++ b/Alpha/Repl.scm
@@ -0,0 +1,23 @@
+(define-module (Alpha Repl)
+  #:export ())
+
+
+;;
+;; repl customization
+;;
+
+;; (use-modules (system repl common))
+;; (repl-default-option-set!
+;;  'prompt
+;;  (lambda (repl)
+;;    (format #f "\n[~a@~a:~a]\nλ> "
+;;            (getenv "USER")
+;;            (vector-ref (uname) 1)
+;;            (pwd))))
+
+;; TODO(bsima): (doc x)
+;; TODO(bsima): (src x)
+;; TODO(bsima): ,src command
+;; TODO(bsima): ,shell command
+;; TODO(bsima): how to load this file on startup?
+;; for ,src and ,shell https://github.com/NalaGinrut/nala-repl
diff --git a/Alpha/Shell.scm b/Alpha/Shell.scm
new file mode 100644
index 0000000..3f52fd2
--- /dev/null
+++ b/Alpha/Shell.scm
@@ -0,0 +1,34 @@
+(define-module (Alpha Shell)
+  #:use-module ((ice-9 popen) #:prefix popen/)
+  #:use-module ((ice-9 rdelim) #:prefix rdelim/)
+  #:use-module ((ice-9 ftw) #:prefix ftw/)
+  #:export (exec
+            stream
+            pwd
+            ls
+            cd))
+
+(define (exec cmd)
+  (let* ((port (popen/open-input-pipe cmd))
+         (ret (read port)))
+    (popen/close-pipe port)
+    ret))
+
+(define (stream cmd)
+  (let* ((port (popen/open-input-pipe cmd))
+         (_ (setvbuf port 'none))
+         (ret (rdelim/read-string port)))
+    (flush-all-ports)
+    (popen/close-pipe port)
+    ret))
+
+(define (pwd)
+  (regexp-substitute/global
+   #f "/home/ben" (getcwd) 'pre "~" 'post))
+
+(define (ls)
+  (ftw/scandir (getcwd)))
+
+(define (cd path)
+  (chdir path)
+  (ls))
diff --git a/Alpha/String.scm b/Alpha/String.scm
new file mode 100644
index 0000000..779c2fb
--- /dev/null
+++ b/Alpha/String.scm
@@ -0,0 +1,24 @@
+(define-module (Alpha String)
+  #:export (replace to-string str capitalize))
+
+(define (replace s match repl)
+  (let ((f (lambda (a b)
+             (let ((next-char (if (eq? a match) repl a)))
+               (string-concatenate (list b (string next-char)))))))
+    (string-fold f "" s)))
+
+(define (to-string x)
+  (format #f "~a" x))
+
+(define str
+  (case-lambda
+    (() "")
+    ((x) (to-string x))
+    ((x . rest) (string-concatenate (map str (cons x rest))))))
+
+(define (capitalize s)
+  (let ((s (to-string s)))
+    (if (< (string-length s) 2)
+        (string-upcase s)
+        (str (string-upcase (substring s 0 1))
+             (substring s 1 )))))
diff --git a/Alpha/Test.scm b/Alpha/Test.scm
new file mode 100644
index 0000000..8c0916d
--- /dev/null
+++ b/Alpha/Test.scm
@@ -0,0 +1,16 @@
+;; a testing framework for scheme
+;; inspired by clojure.test and srfi-64
+
+(define-module (Alpha Test)
+  #:use-module ((Alpha Core)
+                #:select (prn))
+  #:export (testing))
+
+;; TODO: learn srfi-64
+;; TODO: port over `deftest' et al from clojure
+;; TODO: someday a quickcheck-like would be best
+
+;; simple analog to clojure's `testing'
+(define-syntax testing
+  ((_ description ...)
+   ((begin (prn description) ...))))