summaryrefslogtreecommitdiff
path: root/Alpha
diff options
context:
space:
mode:
Diffstat (limited to 'Alpha')
-rw-r--r--Alpha/Core.scm221
-rw-r--r--Alpha/Logic.scm239
-rw-r--r--Alpha/Repl.scm17
-rw-r--r--Alpha/Shell.scm32
-rw-r--r--Alpha/String.scm72
-rw-r--r--Alpha/Test.scm16
6 files changed, 0 insertions, 597 deletions
diff --git a/Alpha/Core.scm b/Alpha/Core.scm
deleted file mode 100644
index 076ad28..0000000
--- a/Alpha/Core.scm
+++ /dev/null
@@ -1,221 +0,0 @@
-(define-module (Alpha Core)
- #:use-module ((ice-9 format))
- #:use-module ((system vm program))
- #:use-module ((ice-9 rdelim) #:select (read-line))
- #:use-module (srfi srfi-1)
- #:export (fmt printf pr prn rest last butlast
- true? false? some? empty?
- -> ->> fn /. curry comp
- repeat for seq turn
- inc dec member? contains?
- comment get-source* get-source source))
-
-(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 (sum lst) (fold + 0 lst))
-(define (product lst) (fold * 1 lst))
-
-(define count length)
-
-(define (pr . a)
- "Print"
- (for-each display a))
-
-(define (prn . a)
- "Print, followed by a newline"
- (apply pr a)
- (newline))
-
-(define (false? x)
- (not (eq? #t x)))
-
-(define (true? x)
- (eq? #t x))
-
-(define (some? a)
- (not (null? a)))
-
-(define (empty? a)
- (equal? a '()))
-
-(define (ffirst a)
- (first (first a)))
-
-(define (rest a)
- "Returns a list of the items after the first."
- (cdr a))
-
-(define (last coll)
- "Return the last time in coll, in linear time."
- (if (second coll)
- (last (rest coll))
- (first coll)))
-
-(define (butlast ls)
- "Return everthing execpt the last element in ls."
- (let ((len (length ls)))
- (list-head ls (- len 1))))
-
-;; Ignores body, returns '().
-(define-syntax comment
- (syntax-rules ()
- ((_ ...) '())))
-
-(define (some pred coll)
- (or (pred (first coll))
- (some pred (second 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 ...))))
-
-(define-syntax fn
- (syntax-rules ()
- ((_ args body ...)
- (lambda args body ...))))
-
-(define-syntax ->
- (syntax-rules ()
- [(_ a) a]
- [(_ a (b c ...))
- (b a c ...)]
- [(_ a b)
- (-> a (b))]
- [(_ a b c ...)
- (-> (-> a b) c ...)]))
-
-(define-syntax ->>
- (syntax-rules ()
- [(_ a) a]
- [(_ a (b ...))
- (b ... a)]
- [(_ a b)
- (b a)]
- [(_ a b c ...)
- (->> (->> a b) c ...)]))
-
-;; Shen-like lambda
-(define-syntax /.
- (syntax-rules ()
- [(/. a b)
- (lambda (a) b)]
- [(/. a ... b)
- (lambda (a ...) b)]
- [(/. a ... (b ...))
- (lambda (a ...) (b ...))]))
-
-(define (inc a) (+ a 1))
-(define (dec a) (- a 1))
-
-(define* (repeat a #:optional (n 10))
- (do ((i 1 (inc i)))
- ((> i n))
- a))
-
-(define-syntax if-let
- (syntax-rules ()
- [(_ (binding value) then else)
- (let ([binding value])
- (if binding then else))]))
-
-(define-syntax when-let
- (syntax-rules ()
- [(_ (binding value) body ...)
- (when binding body ...)]))
-
-
-;; source utils
-
-(define (skip-lines port n)
- (cond
- ((zero? n) port)
- (else (read-line port) (skip-lines port (1- n)))))
-
-(define (get-source* source pname)
- (let* ([file (source:file source)]
- [filename (any (fn (x)
- (let ((f (string-append x "/" file)))
- (if (file-exists? f) f #f)))
- %load-path)]
- [re (make-regexp (format #f "\\(define (~a|\\(~a.*\\))" pname pname))]
- [read-between (lambda (in start end)
- (seek in 0 SEEK_SET)
- (skip-lines in (1- start))
- (call-with-output-string
- (lambda (out)
- (let self ((line (read-line in))
- (cur start))
- (cond
- [(or (eof-object? line) (> cur end))
- (close in)]
- [else
- (format out "~a~%" line)
- (self (read-line in) (inc cur))])))))])
- (call-with-input-file filename
- (lambda (in)
- (let self ((line (read-line in)))
- (cond
- [(eof-object? line) #f]
- [(regexp-exec re line)
- (unread-string line in)
- (let* ((start (port-line in))
- (end (begin (read in) (port-line in))))
- (read-between in start (inc end)))]
- [else
- (self (read-line in))]))))))
-
-(define (get-source p)
- "Get the source of a procedure as a string."
- (let ((psrc (program-source p 0)))
- (cond
- [(not psrc) (fmt "<~a: compiled C procedure>\n" p)]
- [(not (source:file psrc)) #f]
- [else (get-source* psrc (symbol->string (procedure-name p)))])))
-
-(define (source p)
- "Print the source of a procedure."
- (pr (get-source p)))
-
-(define member? member)
-
-(define (contains? ls x)
- (member? x ls))
-
-(define (turn ls f)
- (map f ls))
-
-(define (seq x)
- (if (list? x)
- x
- (list x)))
-
-;; is this not in srfi-1?
-(define (flatten x)
- (cond ((null? x) '())
- ((pair? x) (append (flatten (car x)) (flatten (cdr x))))
- (else (list x))))
diff --git a/Alpha/Logic.scm b/Alpha/Logic.scm
deleted file mode 100644
index 4b160d8..0000000
--- a/Alpha/Logic.scm
+++ /dev/null
@@ -1,239 +0,0 @@
-;; my mini kanren impl - basically untested so far
-;; TODO: https://github.com/webyrd/faster-miniKanren
-
-(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
deleted file mode 100644
index f3f7898..0000000
--- a/Alpha/Repl.scm
+++ /dev/null
@@ -1,17 +0,0 @@
-(define-module (Alpha Repl))
-;; (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)
-
-(eval-when (compile load eval)
- (define-meta-command ((src nala) repl (form))
- "Print source code of specified Scheme procedure."
- (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
- (lambda args (for-each print-src args)))))
diff --git a/Alpha/Shell.scm b/Alpha/Shell.scm
deleted file mode 100644
index b00b174..0000000
--- a/Alpha/Shell.scm
+++ /dev/null
@@ -1,32 +0,0 @@
-(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 getcwd)
-
-(define (ls)
- (ftw/scandir (getcwd)))
-
-(define (cd path)
- (chdir path)
- (ls))
diff --git a/Alpha/String.scm b/Alpha/String.scm
deleted file mode 100644
index 6e29663..0000000
--- a/Alpha/String.scm
+++ /dev/null
@@ -1,72 +0,0 @@
-(define-module (Alpha String)
- #:export (replace replace-char to-string str capitalize split
- strip lstrip rstrip))
-
-(define (split s c)
- (if s
- (string-split s c)
- #f))
-
-(define (replace-char 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 (replace s match repl)
- (string-replace-substring s match repl))
-
-(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 )))))
-
-(define (strip s char)
- (string-trim-both s char))
-
-(define (lstrip s char)
- (string-trim s char))
-
-(define (rstrip s char)
- (string-trim-right s char ))
-
-
-;;; {String Fun: string-replace-substring}
-;;;
-
-;; string-replace-substring By A. Wingo in
-;; https://lists.gnu.org/archive/html/guile-devel/2014-03/msg00058.html
-;; also in string-replace-substring guix:guix/utils.scm.
-
-(define (string-replace-substring str substring replacement)
- "Return a new string where every instance of @var{substring} in string
- @var{str} has been replaced by @var{replacement}. For example:
-
- @lisp
- (string-replace-substring \"a ring of strings\" \"ring\" \"rut\")
- @result{} \"a rut of struts\"
- @end lisp
- "
- (let ((sublen (string-length substring)))
- (with-output-to-string
- (lambda ()
- (let lp ((start 0))
- (cond
- ((string-contains str substring start)
- => (lambda (end)
- (display (substring/shared str start end))
- (display replacement)
- (lp (+ end sublen))))
- (else
- (display (substring/shared str start)))))))))
diff --git a/Alpha/Test.scm b/Alpha/Test.scm
deleted file mode 100644
index 8c0916d..0000000
--- a/Alpha/Test.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-;; 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) ...))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 18:31:57 +0000