1.1--- a/lisp/bin/homer.lisp Thu Aug 08 23:01:20 2024 -0400
1.2+++ b/lisp/bin/homer.lisp Sat Aug 10 00:30:45 2024 -0400
1.3@@ -185,7 +185,7 @@
1.4 :name "homer"
1.5 :version "0.1.0"
1.6 :description "user home manager"
1.7- :thunk homer-check
1.8+ :thunk 'homer-check
1.9 :opts ((:name "level" :global t :description "set the log level" :thunk homer-log-level)
1.10 (:name "help" :global t :description "print help" :thunk homer-help)
1.11 (:name "version" :global t :description "print version" :thunk homer-version)
2.1--- a/lisp/bin/organ.lisp Thu Aug 08 23:01:20 2024 -0400
2.2+++ b/lisp/bin/organ.lisp Sat Aug 10 00:30:45 2024 -0400
2.3@@ -37,7 +37,7 @@
2.4 :name "organ"
2.5 :version "0.0.1"
2.6 :description "org-mode toolbox"
2.7- :thunk organ-describe
2.8+ :thunk 'organ-describe
2.9 :opts ((:name "level" :global t :description "set the log level" :thunk organ-log-level)
2.10 (:name "help" :global t :description "print help" :thunk organ-help)
2.11 (:name "version" :global t :description "print version" :thunk organ-version)
3.1--- a/lisp/bin/packy.lisp Thu Aug 08 23:01:20 2024 -0400
3.2+++ b/lisp/bin/packy.lisp Sat Aug 10 00:30:45 2024 -0400
3.3@@ -16,7 +16,7 @@
3.4 :name "packy"
3.5 :version "0.1.0"
3.6 :description "Universal Package Manager"
3.7- :thunk pk-show
3.8+ :thunk 'pk-show
3.9 :opts ((:name "level" :global t :description "set the log level" :thunk pk-log-level)
3.10 (:name "help" :global t :description "print help" :thunk pk-help)
3.11 (:name "version" :global t :description "print version" :thunk pk-version))
4.1--- a/lisp/bin/rdb.lisp Thu Aug 08 23:01:20 2024 -0400
4.2+++ b/lisp/bin/rdb.lisp Sat Aug 10 00:30:45 2024 -0400
4.3@@ -15,7 +15,7 @@
4.4
4.5 ;; (defopt rdb-config (init-rdb-user-config (parse-file-opt *arg*)))
4.6
4.7-(defcmd rdb-new
4.8+(defcmd rdb-new ()
4.9 (set-opt *rdb* :error-if-exists t)
4.10 (open-db *rdb*)
4.11 (println (rdb-name *rdb*)))
4.12@@ -72,14 +72,16 @@
4.13 (define-cli *cli*
4.14 :name "rdb"
4.15 :version "0.1.0"
4.16- :thunk rdb-show
4.17+ :thunk 'rdb-show
4.18 :description "A simple helper for RocksDB."
4.19 :opts ((:name "level" :global t :description "set the log level" :thunk rdb-log-level)
4.20 (:name "help" :global t :description "print help" :thunk rdb-help)
4.21 (:name "version" :global t :description "print version" :thunk rdb-version)
4.22 (:name "db" :global t :description "target db" :thunk rdb-target-db :kind dir))
4.23- :cmds ((:name new :thunk rdb-new)
4.24- (:name show :thunk rdb-show)
4.25+ :cmds ((:name new
4.26+ :thunk rdb-new)
4.27+ (:name show
4.28+ :thunk rdb-show)
4.29 (:name set :thunk rdb-set)
4.30 (:name get :thunk rdb-get)
4.31 (:name fuzz :thunk rdb-fuzz)
5.1--- a/lisp/bin/skel.lisp Thu Aug 08 23:01:20 2024 -0400
5.2+++ b/lisp/bin/skel.lisp Sat Aug 10 00:30:45 2024 -0400
5.3@@ -4,7 +4,7 @@
5.4 ;; level. :INPUT :WAIT :OUTPUT
5.5 (in-package :std-user)
5.6 (defpkg :bin/skel
5.7- (:use :cl :std :cli/clap
5.8+ (:use :cl :std :cli/clap :cli/clap/vars
5.9 :vc :sb-ext :skel :log
5.10 :dat/sxp #+tools :skel/tools/viz)
5.11 (:import-from :cli/shell :*shell-input*)
5.12@@ -231,11 +231,11 @@
5.13 :name "skel"
5.14 :version #.(format nil "0.1.1:~A" (read-line (sb-ext:process-output (vc:run-hg-command "id" '("-i") :stream))))
5.15 :description "A hacker's project compiler."
5.16- :thunk skc-show
5.17+ :thunk 'skc-show
5.18 :opts ((:name "help" :global t :description "print this message"
5.19- :thunk skc-help)
5.20- (:name "version" :global t :description "print version"
5.21- :thunk skc-version)
5.22+ :thunk skc-help)
5.23+ (:name "version" :global t :description "print version"
5.24+ :thunk skc-version)
5.25 (:name "level" :global t :description "set log level (warn,info,debug,trace)"
5.26 :thunk skc-level)
5.27 (:name "config" :global t :description "set a custom skel user config" :kind file)
5.28@@ -243,7 +243,7 @@
5.29 (:name "output" :global t :description "output target" :kind string))
5.30 :cmds ((:name init
5.31 :description "initialize a skelfile in the current directory"
5.32- :opts ((:name "name" :description "project name" :kind string))
5.33+ :opts (:name "name" :description "project name" :kind string)
5.34 :thunk skc-init)
5.35 (:name new
5.36 :description "make a new skel project"
6.1--- a/lisp/lib/cli/clap/cli.lisp Thu Aug 08 23:01:20 2024 -0400
6.2+++ b/lisp/lib/cli/clap/cli.lisp Sat Aug 10 00:30:45 2024 -0400
6.3@@ -14,15 +14,20 @@
6.4 ((eql kind :cmd) (apply #'make-instance 'cli-cmd slots))
6.5 (t (apply #'make-instance kind slots))))
6.6
6.7-(defmacro define-cli (name &body body)
6.8+(defmacro define-cli (sym &key name version description thunk opts cmds)
6.9 "Define a symbol NAME bound to a top-level CLI object."
6.10 (with-gensyms (%name %class)
6.11- (if (atom name)
6.12- (setq %name name
6.13+ (if (atom sym)
6.14+ (setq %name sym
6.15 %class :cli)
6.16- (setq %name (car name)
6.17- %class (cdr name)))
6.18- `(,*default-cli-def* ,%name (apply #'make-cli ,%class ',body))))
6.19+ (setq %name (car sym)
6.20+ %class (cdr sym)))
6.21+ `(,*default-cli-def* ,%name (make-cli ,%class :name ,name
6.22+ :version ,version
6.23+ :description ,description
6.24+ :thunk ,thunk
6.25+ :opts (make-opts ',opts)
6.26+ :cmds (make-cmds ',cmds)))))
6.27
6.28 (defmacro defmain ((&key (exit t) (export t)) &body body)
6.29 "Define a CLI main function in the current package."
6.30@@ -38,7 +43,7 @@
6.31 ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags
6.32 ;; to avoid conflicts. if not, need something like a flag-function
6.33 ;; slot at class allocation.
6.34-(defun make-opts (&rest opts)
6.35+(defun make-opts (opts)
6.36 "Make a vector of CLI-OPTs based on OPTS."
6.37 (map 'vector
6.38 (lambda (x)
6.39@@ -48,7 +53,7 @@
6.40 (t (make-cli :opt :name (format nil "~(~A~)" x) :global t))))
6.41 opts))
6.42
6.43-(defun make-cmds (&rest cmds)
6.44+(defun make-cmds (cmds)
6.45 "Make a vector of CLI-CMDs based on CMDS."
6.46 (map 'vector
6.47 (lambda (x)
7.1--- a/lisp/lib/cli/tests.lisp Thu Aug 08 23:01:20 2024 -0400
7.2+++ b/lisp/lib/cli/tests.lisp Sat Aug 10 00:30:45 2024 -0400
7.3@@ -216,9 +216,8 @@
7.4 (is (string= "foobar"
7.5 (completing-read "nothing: " tcoll :history thist :default "foobar")))))
7.6
7.7-(defparameter *opts* (make-opts
7.8- '(:name "foo" :global t :description "bar")
7.9- '(:name "bar" :description "foo")))
7.10+(defparameter *opts* '((:name "foo" :global t :description "bar")
7.11+ (:name "bar" :description "foo")))
7.12
7.13 (defparameter *cmd1* (make-cli :cmd :name "holla" :opts *opts* :description "cmd1 description"))
7.14 (defparameter *cmd2* (make-cli :cmd :name "ayo" :cmds #(*cmd1*) :opts *opts* :description "cmd1 description"))
8.1--- a/lisp/lib/net/fetch.lisp Thu Aug 08 23:01:20 2024 -0400
8.2+++ b/lisp/lib/net/fetch.lisp Sat Aug 10 00:30:45 2024 -0400
8.3@@ -3,19 +3,26 @@
8.4 (define-condition invalid-path-error (error)
8.5 ((text :initarg :text :reader text)))
8.6
8.7-(defun download (url &key output (if-exists :error))
8.8- (let ((output (if output
8.9- output
8.10- (file-namestring (obj/uri:uri-path (obj/uri:uri url))))))
8.11+(defun download (url &key (output (obj/uri:uri-path (obj/uri:uri url)))
8.12+ (if-exists :error) (progress nil) (connect-timeout net/req:*default-connect-timeout*)
8.13+ cookies)
8.14+ (let ((*progress-bar-enabled* progress))
8.15 (multiple-value-bind (stream status header uri)
8.16- (req:get url :want-stream t :force-binary t)
8.17+ (req:get url :want-stream t :force-binary t :connect-timeout connect-timeout :verbose (log:trace-p)
8.18+ :cookie-jar cookies)
8.19 (when (= status 200)
8.20- (with-open-file (out output :direction :output :element-type '(unsigned-byte 8) :if-exists if-exists)
8.21- (loop for c = (read-byte stream nil nil)
8.22- while c
8.23- do (write-byte c out))))
8.24- (values (or stream uri header)
8.25- status))))
8.26+ (log:debug! "download connect OK:" url)
8.27+ (log:debug! "headers:" (hash-table-alist header))
8.28+ (let ((len (gethash "content-length" header)))
8.29+ (when len (setf len (parse-integer len)))
8.30+ (with-progress-bar (len "downloading ~a to ~a..." url output)
8.31+ (with-open-file (out output :direction :output :element-type '(unsigned-byte 8) :if-exists if-exists)
8.32+ (loop for c = (read-byte stream nil nil)
8.33+ while c
8.34+ do (progn
8.35+ (update-progress *progress-bar* 1)
8.36+ (write-byte c out)))))
8.37+ (values stream status uri header))))))
8.38
8.39 (defun split-file-path (path)
8.40 (let ((pos-last-slash (1+ (position #\/ path :from-end t))))
9.1--- a/lisp/lib/net/net.asd Thu Aug 08 23:01:20 2024 -0400
9.2+++ b/lisp/lib/net/net.asd Sat Aug 10 00:30:45 2024 -0400
9.3@@ -10,7 +10,7 @@
9.4 :dat :obj
9.5 :io :parse
9.6 :swank-client
9.7- :cl+ssl
9.8+ :cl+ssl :cli
9.9 :chipz :babel :chunga
9.10 :std :log)
9.11 :serial t
10.1--- a/lisp/lib/net/pkg.lisp Thu Aug 08 23:01:20 2024 -0400
10.2+++ b/lisp/lib/net/pkg.lisp Sat Aug 10 00:30:45 2024 -0400
10.3@@ -320,7 +320,7 @@
10.4
10.5 (defpackage :net/fetch
10.6 (:nicknames :fetch)
10.7- (:use :cl :std :obj/uri)
10.8+ (:use :cl :std :obj/uri :cli/progress)
10.9 (:export :fetch :download))
10.10
10.11 (defpackage :net/srv
11.1--- a/lisp/lib/q/dql.lisp Thu Aug 08 23:01:20 2024 -0400
11.2+++ b/lisp/lib/q/dql.lisp Sat Aug 10 00:30:45 2024 -0400
11.3@@ -60,6 +60,10 @@
11.4
11.5 ;; https://github.com/bobschrag/clolog/blob/main/architecture.md
11.6
11.7+;; https://www.swi-prolog.org/pldoc/man?section=predsummary
11.8+
11.9+;; https://citeseerx.ist.psu.edu/document?repid=rep1&type=pdf&doi=cc7dcdf130adbd7be4d0ed5d3f4ea890e4477223
11.10+
11.11 ;;; Code:
11.12 (in-package :q/dql)
11.13
11.14@@ -69,17 +73,60 @@
11.15 (defvar *lips* 0
11.16 "Count of logical inferences performed.")
11.17
11.18+(defvar *leash-limit* nil)
11.19+
11.20+(defvar *leash-indent-wrap* 20
11.21+ "The output to *LEASH-OUTPUT* indents by one level for each level of a predicate, modulo this value.")
11.22+
11.23+(defvar *leash-output* (make-synonym-stream '*trace-output*))
11.24+
11.25 ;; from GAMBOL
11.26-(defvar *interactive* t "true iff interacting with user")
11.27-(defvar *auto-backtrack* nil "return all solutions if true")
11.28-(defvar *last-continuation* nil "saved state of the system")
11.29-(defvar *trail* nil "the trail, for backtracking")
11.30-(defvar *x-env* nil "env for goals")
11.31-(defvar *y-env* nil "env for rules")
11.32-(defvar *top-level-envs* nil "saves top-level environments")
11.33-(defvar *top-level-vars* nil "saves top-level variable names")
11.34-(defvar *num-slots* -1 "number of logical variables in a query")
11.35-(defvar *rules* (make-hash-table) "hash table for prolog rule heads")
11.36+(defvar *interactive* t
11.37+ "true iff interacting with user")
11.38+(defvar *auto-backtrack* nil
11.39+ "return all solutions if true")
11.40+(defvar *last-continuation* nil
11.41+ "saved state of the system")
11.42+(defvar *trail* nil
11.43+ "the trail, for backtracking")
11.44+(defvar *x-env* nil
11.45+ "env for goals")
11.46+(defvar *y-env* nil
11.47+ "env for rules")
11.48+(defvar *top-level-envs* nil
11.49+ "saves top-level environments")
11.50+(defvar *top-level-vars* nil
11.51+ "saves top-level variable names")
11.52+(defvar *rules* (make-hash-table)
11.53+ "hash table for prolog rule heads")
11.54+(defvar *facts* nil
11.55+ "Facts are uncoditional truths. They are expressed simply as rules with no
11.56+variables in the head and no clauses in the body. During reading of a DQL
11.57+form, if we find any facts we evaluate them and store them here.")
11.58+
11.59+;;; Utils
11.60+(defconstant +impossible+ 'no "make impossible look nice")
11.61+(defconstant +solved+ 'yes "make solved look nice")
11.62+
11.63+(defconstant +?+ #\?)
11.64+
11.65+(defun dql-variable-p (sym)
11.66+ "Valid DQL variables are symbols which start with the character #\? as in '?FOO
11.67+and '?BAR."
11.68+ (and (symbolp sym)
11.69+ (eql (char (symbol-name sym) 0) +?+)))
11.70+
11.71+(deftype dql-variable () `(satisfies dql-variable-p))
11.72+
11.73+(defun dql-anonymous-p (sym)
11.74+ "Return T if SYM is a DQL anonymous variable represented by the value of +?+."
11.75+ (eq sym (symbolicate +?+)))
11.76+
11.77+(deftype dql-anonymous () '(satisfies dql-anonymous-p))
11.78+
11.79+(defgeneric proof-tree (self))
11.80+
11.81+(defgeneric print-proof-tree (self &optional stream))
11.82
11.83 ;;; Conditions
11.84 (define-condition dql-error (error) ())
11.85@@ -89,24 +136,72 @@
11.86 (defun simple-dql-error (ctrl &rest args)
11.87 (error 'simpl-dql-error :format-control ctrl :format-arguments args))
11.88
11.89+(define-condition invalid-dql-anonymous (dql-error) ())
11.90+
11.91+(define-condition invalid-dql-variable (dql-error) ())
11.92+
11.93+;;; Prolog Predicates
11.94+(defun dql-predicate-p (sym)
11.95+ "Check if SYM looks like a DQL predicate. It shoulb be suffixed by a #\/
11.96+followed by either '* for vararg functors or an integer indicating the arity
11.97+of the predicate. On success returns the arity or T for varargs."
11.98+ (when-let ((arity (cdr (ssplit #\/ (symbol-name sym)))))
11.99+ (setf (the simple-string arity) (car arity))
11.100+ (or (and
11.101+ (digit-char-p (char arity 0))
11.102+ (parse-integer arity))
11.103+ (char= (char arity 0) #\*))))
11.104+
11.105+;; ports: call, exit, redo, and fail
11.106+
11.107+;; define-functor
11.108+
11.109+;;; Lisp Operators
11.110+
11.111+(defmacro <- (head &body body))
11.112+(defmacro <-- (head &body body))
11.113+
11.114+(defmacro ?- (&body clauses)
11.115+ "Enter the interactive DQL execution environment, attempting to solve for
11.116+CLAUSES.")
11.117+
11.118+
11.119+(defmacro leash (&body (functor arity))
11.120+ "Prolog equivalent of CL:TRACE."
11.121+ (print functor) (print arity))
11.122+
11.123+(defmacro unleash (&body (functor arity))
11.124+ "Prolog equivalent of CL:UNTRACE."
11.125+ (print functor) (print arity))
11.126+
11.127+(defun prolog-compile-symbols (&rest functors))
11.128+
11.129+;; cut
11.130+;; ref: https://en.wikipedia.org/wiki/Cut_(logic_programming)
11.131+(defconstant +!+ #\!)
11.132+(defun ! () )
11.133+(define-symbol-macro ! (!))
11.134+
11.135+;; equality
11.136+
11.137+;; db manipulation
11.138+
11.139+;; assert, retract, asserta, and assertz
11.140+
11.141+;;; Resolution
11.142+
11.143+;; herbrand universe | ground-terms + pred(P) -> herbrand base | map(true) -> herbrand interpretation
11.144+
11.145+;;;; Unification
11.146+(defun unify (goal))
11.147+
11.148+;; optimistic vs pessimistic when presented with infinite recursion
11.149+
11.150 ;;; CLOS
11.151 (defclass dql-query (query) ())
11.152
11.153 (defclass dql-data-source (data-source) ()
11.154 (:documentation "Data source which can be used withing DQL expressions."))
11.155
11.156-;;; Prolog Semantics
11.157-
11.158-;; NOTE 2024-08-03: we're loosely following along with CL-GAMBOL, but sticking
11.159-;; with defstructs instead of vectors for the most part. I'm willing to pay
11.160-;; the immediate cost of not vectorizing in hopes that the fact that structs
11.161-;; are vector-backed and multi-threaded contexts exist will minimize the
11.162-;; effect.
11.163-
11.164-;;; Macros
11.165-(defmacro ?- (&body clauses))
11.166-
11.167-(defmacro *- (head &body body))
11.168-
11.169 ;;; Parser
11.170 (defclass dql-parser (query-parser) ())
12.1--- a/lisp/lib/q/pkg.lisp Thu Aug 08 23:01:20 2024 -0400
12.2+++ b/lisp/lib/q/pkg.lisp Sat Aug 10 00:30:45 2024 -0400
12.3@@ -65,7 +65,11 @@
12.4 :dql-error
12.5 :dql-data-source
12.6 :dql-query
12.7- :dql-expression))
12.8+ :dql-expression
12.9+ :dql-variable-p
12.10+ :dql-variable
12.11+ :dql-anonymous
12.12+ :dql-anonymous-p))
12.13
12.14 ;; (defpackage :q/e)
12.15
13.1--- a/lisp/lib/q/tests/suite.lisp Thu Aug 08 23:01:20 2024 -0400
13.2+++ b/lisp/lib/q/tests/suite.lisp Sat Aug 10 00:30:45 2024 -0400
13.3@@ -81,3 +81,51 @@
13.4 halt)
13.5
13.6 (:- (initialization main)))
13.7+
13.8+#| SL
13.9+Exercise 2.9. Translate to clausal logic:
13.10+(a) every mouse has a tail;
13.11+(b) somebody loves everybody;
13.12+(c) every two numbers have a maximum.
13.13+|#
13.14+(deftest dql-clausal-simple (:skip t))
13.15+
13.16+;; ref: https://en.wikipedia.org/wiki/Zebra_Puzzle
13.17+
13.18+;; ref: https://franz.com/support/documentation/11.0/prolog.html
13.19+(deftest dql-zebra ()
13.20+ "A solution for the Zebra problem using DQL."
13.21+ (<-- (nextto ?x ?y ?list) (iright ?x ?y ?list))
13.22+ (<- (nextto ?x ?y ?list) (iright ?y ?x ?list))
13.23+ (<-- (iright ?left ?right (?left ?right . ?rest)))
13.24+ (<- (iright ?left ?right (?x . ?rest))
13.25+ (iright ?left ?right ?rest))
13.26+ (<-- (zebra ?h ?w ?z)
13.27+ ;; Each house is of the form:
13.28+ ;; (house nationality pet cigarette drink house-color)
13.29+ (= ?h ((house norwegian ? ? ? ?) ;1,10
13.30+ ?
13.31+ (house ? ? ? milk ?) ? ?)) ; 9
13.32+ (member (house englishman ? ? ? red) ?h) ; 2
13.33+ (member (house spaniard dog ? ? ?) ?h) ; 3
13.34+ (member (house ? ? ? coffee green) ?h) ; 4
13.35+ (member (house ukrainian ? ? tea ?) ?h) ; 5
13.36+ (iright (house ? ? ? ? ivory) ; 6
13.37+ (house ? ? ? ? green) ?h)
13.38+ (member (house ? snails winston ? ?) ?h) ; 7
13.39+ (member (house ? ? kools ? yellow) ?h) ; 8
13.40+ (nextto (house ? ? chesterfield ? ?) ;11
13.41+ (house ? fox ? ? ?) ?h)
13.42+ (nextto (house ? ? kools ? ?) ;12
13.43+ (house ? horse ? ? ?) ?h)
13.44+ (member (house ? ? luckystrike oj ?) ?h) ;13
13.45+ (member (house japanese ? parliaments ? ?) ?h) ;14
13.46+ (nextto (house norwegian ? ? ? ?) ;15
13.47+ (house ? ? ? ? blue) ?h)
13.48+ (member (house ?w ? ? water ?) ?h) ;Q1
13.49+ (member (house ?z zebra ? ? ?) ?h)) ;Q2
13.50+ ;; execute the query
13.51+ (?- (zebra ?houses ?water-drinker ?zebra-owner))
13.52+ ;; It is believed that solving zebra a
13.53+ ;; single time requires 12825 inferences.
13.54+ )
14.1--- a/lisp/lib/syn/syn.asd Thu Aug 08 23:01:20 2024 -0400
14.2+++ b/lisp/lib/syn/syn.asd Sat Aug 10 00:30:45 2024 -0400
14.3@@ -1,6 +1,6 @@
14.4 (defsystem :syn
14.5 :version "0.1.0"
14.6- :maintainer "ellis <ellis@rwest.io>"
14.7+ :maintainer "Richard Westhaver <richard.westhaver@gmail.com>"
14.8 :bug-tracker "https://vc.compiler.company/comp/core/issues"
14.9 :depends-on (:std :obj :parse :tree-sitter)
14.10 :serial t
15.1--- a/skelfile Thu Aug 08 23:01:20 2024 -0400
15.2+++ b/skelfile Sat Aug 10 00:30:45 2024 -0400
15.3@@ -42,6 +42,9 @@
15.4 (parquet.json (%stash)
15.5 (download "https://packy.compiler.company/data/parquet.json"
15.6 :output ".stash/parquet.json"))
15.7+ (freedesktop.org.xml (%stash)
15.8+ (download "https://packy.compiler.company/data/freedesktop.org.xml"
15.9+ :output ".stash/freedesktop.org.xml"))
15.10 (parquet-test-data (%stash) (download "https://packy.compiler.company/data/test/alltypes_plain.parquet"
15.11 :output ".stash/alltypes_plain.parquet"))
15.12 ;; lisp
