From 8a99fe910b7a5921e21d7e7cfefd0a4838fcfad4 Mon Sep 17 00:00:00 2001 From: mehbark Date: Mon, 16 Dec 2024 14:34:52 -0500 Subject: [PATCH] initial --- bel.lisp | 85 ++ classic.lisp | 25 + clos-adt.lisp | 1 + clpfd.lisp | 34 + compile-lc.lisp | 16 + convert.lisp | 68 ++ count-nodes.lisp | 4 + defadt.lisp | 33 + flow.lisp | 39 + maxima-stochiometry.lisp | 2 + polish.lisp | 8 + questions.lisp | 39 + quicklisp.lisp | 1757 ++++++++++++++++++++++++++++++++++++++ sat.lisp | 36 + to-desmos.lisp | 30 + undesirable-macros.lisp | 29 + utils.lisp | 698 +++++++++++++++ word-search.lisp | 25 + 18 files changed, 2929 insertions(+) create mode 100644 bel.lisp create mode 100644 classic.lisp create mode 100644 clos-adt.lisp create mode 100644 clpfd.lisp create mode 100644 compile-lc.lisp create mode 100644 convert.lisp create mode 100644 count-nodes.lisp create mode 100644 defadt.lisp create mode 100644 flow.lisp create mode 100644 maxima-stochiometry.lisp create mode 100644 polish.lisp create mode 100644 questions.lisp create mode 100644 quicklisp.lisp create mode 100644 sat.lisp create mode 100644 to-desmos.lisp create mode 100644 undesirable-macros.lisp create mode 100644 utils.lisp create mode 100644 word-search.lisp diff --git a/bel.lisp b/bel.lisp new file mode 100644 index 0000000..369e336 --- /dev/null +++ b/bel.lisp @@ -0,0 +1,85 @@ +(load "utils.lisp") + +(defun string->chars (s) + (declare (type string s)) + (map 'list #'identity s)) + +(defun chars->string (cs) + (map 'string #'identity cs)) + +(defparameter prims + `((id . ,#'eq) + (ins . ,*terminal-io*) + (outs . ,*terminal-io*) + (join . ,#'(lambda (&optional a b) (cons a b))) + (car . ,#'car) + (cdr . ,#'cdr) + (apply . ,#'(lambda (f &rest args) (apply #'call f args))) + (type . ,#'(lambda (x) + (typecase x + (symbol 'symbol) + (cons 'pair) + (character 'char) + (stream 'stream)))) + (sym . ,(fn (intern chars->string))) + (nom . ,(fn (string->chars symbol-name))) + (coin . ,#'(lambda () (zerop (random 2)))) + ;; todo + (sys . ,(fn (uiop:run-program chars->string))))) + +(defclass lit () + ((tag :initarg :tag) + (stuff :initarg :stuff))) + +(defmethod print-object ((obj lit) stream) + (with-slots (tag stuff) obj + (format stream "#lit#~s#~s" tag stuff))) + +(defmacro lit (tag &rest stuff) + `(make-instance 'lit :tag ',tag :stuff ',stuff)) + +(defun call (f &rest args) + (format t "~s ~s~%" f args) + (typecase f + (function (apply f args)) + (lit + (with-slots (tag stuff) f + (case tag + (prim (apply (cdr (assoc (car stuff) prims)) + args))))))) + +(defmacro bel-if (&rest branches) + (if branches + `(cond + ,(loop for (a b . rest) on branches by #'cddr + collecting + (if (or b rest) + `(,a ,b) + `(t ,a)))) + nil)) + +;; remember: compile! +(defun bel-compile (expr) + (match expr + ((or 't 'nil 'o + (type number) + (list 'quote _)) + expr) + + ((type string) `',(string->chars expr)) + + ((list 'xar place car) `(setf (car ,(bel-compile place)) ,(bel-compile car))) + ((list 'xdr place cdr) `(setf (cdr ,(bel-compile place)) ,(bel-compile cdr))) + + ((list* 'lit tag stuff) (make-instance 'lit :tag tag :stuff stuff)) + + ((list* 'if branches) + (let1 branches (mapcar #'bel-compile branches) + `(bel-if ,@branches))) + + ((list* f args) `(call ,(bel-compile f) ,@(mapcar #'bel-compile args))) + + ((type symbol) + (aif (assoc expr prims) + `(lit prim ,(car it)) + expr)))) diff --git a/classic.lisp b/classic.lisp new file mode 100644 index 0000000..aaba325 --- /dev/null +++ b/classic.lisp @@ -0,0 +1,25 @@ +(load "utils.lisp") + +(defparameter example + '( + (class (Monoid a) + (mzero a) + (mplus (-> a a a))) + + (instance (Monoid String) + (mzero "") + (mplus (lambda (a b) (native (concatenate 'string a b))))) + + (def + (-> Number Number Number) + (lambda (a b) (native (+ a b)))) + + (instance (Monoid Number) + (mzero 0) + (mplus +)) + + (def msum (=> (Monoid a) (-> (List a) a)) + (lambda (xs) + (List.iter xs + mzero + mplus))) + )) diff --git a/clos-adt.lisp b/clos-adt.lisp new file mode 100644 index 0000000..fdb88b9 --- /dev/null +++ b/clos-adt.lisp @@ -0,0 +1 @@ +;; self-explanatory? diff --git a/clpfd.lisp b/clpfd.lisp new file mode 100644 index 0000000..2f69d26 --- /dev/null +++ b/clpfd.lisp @@ -0,0 +1,34 @@ +(load "utils.lisp") + +(defclass ?v () + ((constraints :initform nil))) + +(defclass constraint () ()) +(defclass c= (constraint) + ((n :initarg :n :type number))) + +;; constr should be generic and return bool +(defvar failure (gensym)) +(defun failure? (sym) (eq sym failure)) + +(defmacro definverse ((?fw ?bw) op) + (with-gensyms (a b a-op-b) + `(progn + (defgeneric ,?fw (,a ,b ,a-op-b)) + (defgeneric ,?bw (,a ,b ,a-op-b)) + + (defmethod ,?bw (,a ,b ,a-op-b) + (,?fw ,b ,a-op-b ,a)) + + (defmethod ,?fw ((,a number) (,b number) (,a-op-b number)) + (if (= (,op ,a ,b) ,a-op-b) + nil + failure)) + + (defmethod ,?fw ((,a number) (,b number) (,a-op-b symbol)) + (list (list '= (,op ,a ,b) ,a-op-b))) + + (defmethod ,?fw ((,a number) (,b symbol) (,a-op-b number)) + (,?bw ))))) + +(definverse (?+ ?-) +) diff --git a/compile-lc.lisp b/compile-lc.lisp new file mode 100644 index 0000000..34a5002 --- /dev/null +++ b/compile-lc.lisp @@ -0,0 +1,16 @@ +(load "utils.lisp") + +(defun to-lisp (term) + (match term + ((list '& vars body) + (let1 vars (mklist vars) + `(lambda ,vars + (declare (type function ,@vars) + (ignorable ,@vars) + (optimize (speed 3) + ;; we know the code is safe + (safety 0))) + ,(to-lisp body)))) + ((list f x) `(funcall ,(to-lisp f) ,(to-lisp x))) + ((list* f x1 xs) (to-lisp `((,f ,x1) ,@xs))) + (x x))) diff --git a/convert.lisp b/convert.lisp new file mode 100644 index 0000000..4554529 --- /dev/null +++ b/convert.lisp @@ -0,0 +1,68 @@ +(load "utils.lisp") +(ql:quickload "fset") +(named-readtables:in-readtable fset:fset-readtable) + +;; TODO: compound +;; let's do the form :cm :cm :cm first + +(defparameter conv + '((:kg (1000 :g)) + (:g (1000 :mg)) + (:m (100 :cm)) + (:km (1000 :m)) + (:in (254/100 :cm)) + (:ft (12 :in)) + (:yd (3 :ft)) + (:mi (1760 :yd)) + (:ml (1 :cm :cm :cm)) + (:hz (1 (:s -1))) + (:acre (4840 (:yd 2))))) + +(defparameter dims + '(((:time) :fs :ps :ns :ms :cs :s :ks :gs :min :hr :day :yr :century :millennium) + ((:length) :fm :pm :nm :mm :cm :m :km :gm :in :ft :yd :mi) + ((:mass) :fg :pg :ng :mg :cg :g :kg :gg :lb) + ((:length 2) :acre) + ((:time -1) :hz))) + +;; multiset is not sufficient! +;; why did i not read this comment! + +(defun dim (&rest dims) + (let1 out (fset:with-default #{| |} 0) + (loop for (dim . rest) on dims + when (keywordp dim) + do (incf (fset:@ out dim) + (if (aand (car rest) + (numberp it)) + (car rest) + 1))) + out)) + +;; maybe should memoize? +;; hash-table would be ffffast +;; eh dw +(defun convs (from) + (loop for (a (n b)) in conv + when (eq a from) + collect `(,n ,b) + when (eq b from) + collect `(,(/ n) ,a))) + +(defun convert (n from to &optional past) + (cond1 + (equal from to) n + (consp from) (cond1 + (atom to) :idk + (longer from to) nil + ;; OMG + (apply #'* + (mapcar (lambda (f to) + (convert n f to (cons from past))) + from to))) + (let1 convs (remove-if #'(lambda (x) (member (cadr x) past :test #'equal)) (convs from)) + (if convs + (loop for (mul new-from) in convs + do (let1 got (convert (* n mul) new-from to (cons from past)) + (if got (return got)))) + nil)))) diff --git a/count-nodes.lisp b/count-nodes.lisp new file mode 100644 index 0000000..1a5e4cf --- /dev/null +++ b/count-nodes.lisp @@ -0,0 +1,4 @@ +(load "utils.lisp") + +; https://www.paulgraham.com/arcchallenge.html + diff --git a/defadt.lisp b/defadt.lisp new file mode 100644 index 0000000..015703c --- /dev/null +++ b/defadt.lisp @@ -0,0 +1,33 @@ +(load "utils.lisp") + +(defmacro defadt (name &rest clauses) + `(prog1 + (defclass ,name () ()) + ,@(loop for clause in clauses + nconcing + (begin + (= (cons clause-name slots) (mklist clause)) + (= keywords (mapcar (lambda (x) (intern (string x) :keyword)) slots)) + `((defclass ,clause-name (,name) + ,(loop for slot in slots + for keyword in keywords + collecting `(,name :initarg ,keyword))) + ,(if slots + `(defun ,clause-name ,slots + (make-instance ',clause-name + ,@(loop for slot in slots + for keyword in keywords + nconcing + `(,keyword ,slot)))) + `(defparameter ,clause-name + (make-instance ',clause-name)))))))) + +;; aaaaand match just works :P + +(defadt NonEmpty (End x) (NCons hd tl)) + +(defun nlength (x) + (declare (type NonEmpty x)) + (match x + ((End (x _)) 1) + ((NCons (hd _) tl) (+ 1 (nlength tl))))) diff --git a/flow.lisp b/flow.lisp new file mode 100644 index 0000000..7d75b3d --- /dev/null +++ b/flow.lisp @@ -0,0 +1,39 @@ +(load "utils.lisp") + +(defclass node () + ((next :initarg :next :initform nil :accessor node-next))) + +(defclass if-node (node) + ((expr :initarg :expr) + (else :initarg :else :initform nil))) + +(defclass output-node (node) + ) + +(defgeneric run (node)) + +(defmethod run ((node node)) + (node-next node)) + +(defmethod run ((node if-node)) + (with-slots (expr next else) node + (if (eval expr) + next + else))) + + +;; start +;; | +;; v +;; x = 10 +;; | +;; v +;; if x = 0 -Y> end +;; | ^ +;; N |<------- +;; v ^ +;; output x | +;; | | +;; v | +;; x = x - 1 ->| + diff --git a/maxima-stochiometry.lisp b/maxima-stochiometry.lisp new file mode 100644 index 0000000..3850737 --- /dev/null +++ b/maxima-stochiometry.lisp @@ -0,0 +1,2 @@ +(load "utils.lisp") + diff --git a/polish.lisp b/polish.lisp new file mode 100644 index 0000000..0f80b54 --- /dev/null +++ b/polish.lisp @@ -0,0 +1,8 @@ +(load "utils.lisp") + +(defun unpole (xs) + (if (inq (car xs) + - * / ^) + (mvbind (lhs rest) (unpole (cdr xs)) + (mvbind (rhs rest) (unpole rest) + (values (list (car xs) lhs rhs) rest))) + (values (car xs) (cdr xs)))) diff --git a/questions.lisp b/questions.lisp new file mode 100644 index 0000000..fe6e68c --- /dev/null +++ b/questions.lisp @@ -0,0 +1,39 @@ +(load "utils.lisp") + +(defstruct node contents yes no) + +(defvar *nodes* (make-hash-table)) + +#+(or) +(defun defnode (name conts &optional yes no) + (setf (gethash name *nodes*) + (make-node :contents conts + :yes yes + :no no))) + +#+(or) +(defun defnode (name conts &optional yes no) + (setf (gethash name *nodes*) + (if yes + #'(lambda () + (funcall + (gethash + (if (eq 'yes (prompt "~a~%>> " conts)) yes no) + *nodes*))) + #'(lambda () conts)))) + +(defnode 'people "Is the person a man?" 'male 'female) +(defnode 'male "Is he living?" 'liveman 'deadman) +(defnode 'deadman "Was he American?" 'us 'them) +(defnode 'us "Is he on a coin?" 'coin 'cidence) +(defnode 'coin "Is the coin a penny?" 'penny 'coins) +(defnode 'penny 'lincoln) + +(defun run-node (name) + (let1 n (gethash name *nodes*) + (cond1 + (node-yes n) (run-node + (if (eq 'yes (prompt "~a~%>> " (node-contents n))) + (node-yes n) + (node-no n))) + (node-contents n)))) diff --git a/quicklisp.lisp b/quicklisp.lisp new file mode 100644 index 0000000..6cda472 --- /dev/null +++ b/quicklisp.lisp @@ -0,0 +1,1757 @@ +;;;; +;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use +;;;; it, start Lisp, then (load "quicklisp.lisp") +;;;; +;;;; Quicklisp is beta software and comes with no warranty of any kind. +;;;; +;;;; For more information about the Quicklisp beta, see: +;;;; +;;;; http://www.quicklisp.org/beta/ +;;;; +;;;; If you have any questions or comments about Quicklisp, please +;;;; contact: +;;;; +;;;; Zach Beane +;;;; + +(cl:in-package #:cl-user) +(cl:defpackage #:qlqs-user + (:use #:cl)) +(cl:in-package #:qlqs-user) + +(defpackage #:qlqs-info + (:export #:*version*)) + +(defvar qlqs-info:*version* "2015-01-28") + +(defpackage #:qlqs-impl + (:use #:cl) + (:export #:*implementation*) + (:export #:definterface + #:defimplementation) + (:export #:lisp + #:abcl + #:allegro + #:ccl + #:clasp + #:clisp + #:cmucl + #:cormanlisp + #:ecl + #:gcl + #:lispworks + #:mkcl + #:scl + #:sbcl)) + +(defpackage #:qlqs-impl-util + (:use #:cl #:qlqs-impl) + (:export #:call-with-quiet-compilation)) + +(defpackage #:qlqs-network + (:use #:cl #:qlqs-impl) + (:export #:open-connection + #:write-octets + #:read-octets + #:close-connection + #:with-connection)) + +(defpackage #:qlqs-progress + (:use #:cl) + (:export #:make-progress-bar + #:start-display + #:update-progress + #:finish-display)) + +(defpackage #:qlqs-http + (:use #:cl #:qlqs-network #:qlqs-progress) + (:export #:fetch + #:*proxy-url* + #:*maximum-redirects* + #:*default-url-defaults*)) + +(defpackage #:qlqs-minitar + (:use #:cl) + (:export #:unpack-tarball)) + +(defpackage #:quicklisp-quickstart + (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar) + (:export #:install + #:help + #:*proxy-url* + #:*asdf-url* + #:*quicklisp-tar-url* + #:*setup-url* + #:*help-message* + #:*after-load-message* + #:*after-initial-setup-message*)) + + +;;; +;;; Defining implementation-specific packages and functionality +;;; + +(in-package #:qlqs-impl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun error-unimplemented (&rest args) + (declare (ignore args)) + (error "Not implemented"))) + +(defmacro neuter-package (name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((definition (fdefinition 'error-unimplemented))) + (do-external-symbols (symbol ,(string name)) + (unless (fboundp symbol) + (setf (fdefinition symbol) definition)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun feature-expression-passes-p (expression) + (cond ((keywordp expression) + (member expression *features*)) + ((consp expression) + (case (first expression) + (or + (some 'feature-expression-passes-p (rest expression))) + (and + (every 'feature-expression-passes-p (rest expression))))) + (t (error "Unrecognized feature expression -- ~S" expression))))) + + +(defmacro define-implementation-package (feature package-name &rest options) + (let* ((output-options '((:use) + (:export #:lisp))) + (prep (cdr (assoc :prep options))) + (class-option (cdr (assoc :class options))) + (class (first class-option)) + (superclasses (rest class-option)) + (import-options '()) + (effectivep (feature-expression-passes-p feature))) + (dolist (option options) + (ecase (first option) + ((:prep :class)) + ((:import-from + :import) + (push option import-options)) + ((:export + :shadow + :intern + :documentation) + (push option output-options)) + ((:reexport-from) + (push (cons :export (cddr option)) output-options) + (push (cons :import-from (cdr option)) import-options)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when effectivep + prep) + (defclass ,class ,superclasses ()) + (defpackage ,package-name ,@output-options + ,@(when effectivep + import-options)) + ,@(when effectivep + `((setf *implementation* (make-instance ',class)))) + ,@(unless effectivep + `((neuter-package ,package-name)))))) + +(defmacro definterface (name lambda-list &body options) + (let* ((forbidden (intersection lambda-list lambda-list-keywords)) + (gf-options (remove :implementation options :key #'first)) + (implementations (set-difference options gf-options))) + (when forbidden + (error "~S not allowed in definterface lambda list" forbidden)) + (flet ((method-option (class body) + `(:method ((*implementation* ,class) ,@lambda-list) + ,@body))) + (let ((generic-name (intern (format nil "%~A" name)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric ,generic-name (lisp ,@lambda-list) + ,@gf-options + ,@(mapcar (lambda (implementation) + (destructuring-bind (class &rest body) + (rest implementation) + (method-option class body))) + implementations)) + (defun ,name ,lambda-list + (,generic-name *implementation* ,@lambda-list))))))) + +(defmacro defimplementation (name-and-options + lambda-list &body body) + (destructuring-bind (name &key (for t) qualifier) + (if (consp name-and-options) + name-and-options + (list name-and-options)) + (unless for + (error "You must specify an implementation name.")) + (let ((generic-name (find-symbol (format nil "%~A" name)))) + (unless (and generic-name + (fboundp generic-name)) + (error "~S does not name an implementation function" name)) + `(defmethod ,generic-name + ,@(when qualifier (list qualifier)) + ,(list* `(*implementation* ,for) lambda-list) ,@body)))) + + +;;; Bootstrap implementations + +(defvar *implementation* nil) +(defclass lisp () ()) + + +;;; Allegro Common Lisp + +(define-implementation-package :allegro #:qlqs-allegro + (:documentation + "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") + (:class allegro) + (:reexport-from #:socket + #:make-socket) + (:reexport-from #:excl + #:read-vector)) + + +;;; Armed Bear Common Lisp + +(define-implementation-package :abcl #:qlqs-abcl + (:documentation + "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") + (:class abcl) + (:reexport-from #:system + #:make-socket + #:get-socket-stream)) + +;;; Clozure CL + +(define-implementation-package :ccl #:qlqs-ccl + (:documentation + "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") + (:class ccl) + (:reexport-from #:ccl + #:make-socket)) + + +;;; CLASP + +(define-implementation-package :clasp #:qlqs-clasp + (:documentation "CLASP - http://github.com/drmeister/clasp") + (:class clasp) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:socket-connect + #:socket-make-stream + #:inet-socket)) + + +;;; GNU CLISP + +(define-implementation-package :clisp #:qlqs-clisp + (:documentation "GNU CLISP - http://clisp.cons.org/") + (:class clisp) + (:reexport-from #:socket + #:socket-connect) + (:reexport-from #:ext + #:read-byte-sequence)) + + +;;; CMUCL + +(define-implementation-package :cmu #:qlqs-cmucl + (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") + (:class cmucl) + (:reexport-from #:ext + #:*gc-verbose*) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:extensions + #:connect-to-inet-socket)) + +(defvar qlqs-cmucl:*gc-verbose* nil) + + +;;; Scieneer CL + +(define-implementation-package :scl #:qlqs-scl + (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") + (:class scl) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:extensions + #:connect-to-inet-socket)) + +;;; ECL + +(define-implementation-package :ecl #:qlqs-ecl + (:documentation "ECL - http://ecls.sourceforge.net/") + (:class ecl) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:socket-connect + #:socket-make-stream + #:inet-socket)) + + +;;; LispWorks + +(define-implementation-package :lispworks #:qlqs-lispworks + (:documentation "LispWorks - http://www.lispworks.com/") + (:class lispworks) + (:prep + (require "comm")) + (:reexport-from #:comm + #:open-tcp-stream + #:get-host-entry)) + + +;;; SBCL + +(define-implementation-package :sbcl #:qlqs-sbcl + (:class sbcl) + (:documentation + "Steel Bank Common Lisp - http://www.sbcl.org/") + (:prep + (require 'sb-bsd-sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-ext + #:compiler-note) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) + +;;; MKCL + +(define-implementation-package :mkcl #:qlqs-mkcl + (:class mkcl) + (:documentation + "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) + +;;; +;;; Utility function +;;; + +(in-package #:qlqs-impl-util) + +(definterface call-with-quiet-compilation (fun) + (:implementation t + (let ((*load-verbose* nil) + (*compile-verbose* nil) + (*load-print* nil) + (*compile-print* nil)) + (handler-bind ((warning #'muffle-warning)) + (funcall fun))))) + +(defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) + (fun) + (declare (ignorable fun)) + (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning)) + (call-next-method))) + +(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) + (fun) + (declare (ignorable fun)) + (let ((qlqs-cmucl:*gc-verbose* nil)) + (call-next-method))) + + +;;; +;;; Low-level networking implementations +;;; + +(in-package #:qlqs-network) + +(definterface host-address (host) + (:implementation t + host) + (:implementation mkcl + (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) + (:implementation sbcl + (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host)))) + +(definterface open-connection (host port) + (:implementation t + (declare (ignorable host port)) + (error "Sorry, quicklisp in implementation ~S is not supported yet." + (lisp-implementation-type))) + (:implementation allegro + (qlqs-allegro:make-socket :remote-host host + :remote-port port)) + (:implementation abcl + (let ((socket (qlqs-abcl:make-socket host port))) + (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) + (:implementation ccl + (qlqs-ccl:make-socket :remote-host host + :remote-port port)) + (:implementation clasp + (let* ((endpoint (qlqs-clasp:host-ent-address + (qlqs-clasp:get-host-by-name host))) + (socket (make-instance 'qlqs-clasp:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-clasp:socket-connect socket endpoint port) + (qlqs-clasp:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation clisp + (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8))) + (:implementation cmucl + (let ((fd (qlqs-cmucl:connect-to-inet-socket host port))) + (qlqs-cmucl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :binary-stream-p t + :input t + :output t))) + (:implementation scl + (let ((fd (qlqs-scl:connect-to-inet-socket host port))) + (qlqs-scl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :input t + :output t))) + (:implementation ecl + (let* ((endpoint (qlqs-ecl:host-ent-address + (qlqs-ecl:get-host-by-name host))) + (socket (make-instance 'qlqs-ecl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-ecl:socket-connect socket endpoint port) + (qlqs-ecl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation lispworks + (qlqs-lispworks:open-tcp-stream host port + :direction :io + :errorp t + :read-timeout nil + :element-type '(unsigned-byte 8) + :timeout 5)) + (:implementation mkcl + (let* ((endpoint (qlqs-mkcl:host-ent-address + (qlqs-mkcl:get-host-by-name host))) + (socket (make-instance 'qlqs-mkcl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-mkcl:socket-connect socket endpoint port) + (qlqs-mkcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation sbcl + (let* ((endpoint (qlqs-sbcl:host-ent-address + (qlqs-sbcl:get-host-by-name host))) + (socket (make-instance 'qlqs-sbcl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-sbcl:socket-connect socket endpoint port) + (qlqs-sbcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full)))) + +(definterface read-octets (buffer connection) + (:implementation t + (read-sequence buffer connection)) + (:implementation allegro + (qlqs-allegro:read-vector buffer connection)) + (:implementation clisp + (qlqs-clisp:read-byte-sequence buffer connection + :no-hang nil + :interactive t))) + +(definterface write-octets (buffer connection) + (:implementation t + (write-sequence buffer connection) + (finish-output connection))) + +(definterface close-connection (connection) + (:implementation t + (ignore-errors (close connection)))) + +(definterface call-with-connection (host port fun) + (:implementation t + (let (connection) + (unwind-protect + (progn + (setf connection (open-connection host port)) + (funcall fun connection)) + (when connection + (close connection)))))) + +(defmacro with-connection ((connection host port) &body body) + `(call-with-connection ,host ,port (lambda (,connection) ,@body))) + + +;;; +;;; A text progress bar +;;; + +(in-package #:qlqs-progress) + +(defclass progress-bar () + ((start-time + :initarg :start-time + :accessor start-time) + (end-time + :initarg :end-time + :accessor end-time) + (progress-character + :initarg :progress-character + :accessor progress-character) + (character-count + :initarg :character-count + :accessor character-count + :documentation "How many characters wide is the progress bar?") + (characters-so-far + :initarg :characters-so-far + :accessor characters-so-far) + (update-interval + :initarg :update-interval + :accessor update-interval + :documentation "Update the progress bar display after this many + internal-time units.") + (last-update-time + :initarg :last-update-time + :accessor last-update-time + :documentation "The display was last updated at this time.") + (total + :initarg :total + :accessor total + :documentation "The total number of units tracked by this progress bar.") + (progress + :initarg :progress + :accessor progress + :documentation "How far in the progress are we?") + (pending + :initarg :pending + :accessor pending + :documentation "How many raw units should be tracked in the next + display update?")) + (:default-initargs + :progress-character #\= + :character-count 50 + :characters-so-far 0 + :update-interval (floor internal-time-units-per-second 4) + :last-update-time 0 + :total 0 + :progress 0 + :pending 0)) + +(defgeneric start-display (progress-bar)) +(defgeneric update-progress (progress-bar unit-count)) +(defgeneric update-display (progress-bar)) +(defgeneric finish-display (progress-bar)) +(defgeneric elapsed-time (progress-bar)) +(defgeneric units-per-second (progress-bar)) + +(defmethod start-display (progress-bar) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (setf (start-time progress-bar) (get-internal-real-time)) + (fresh-line) + (finish-output)) + +(defmethod update-display (progress-bar) + (incf (progress progress-bar) (pending progress-bar)) + (setf (pending progress-bar) 0) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (let* ((showable (floor (character-count progress-bar) + (/ (total progress-bar) (progress progress-bar)))) + (needed (- showable (characters-so-far progress-bar)))) + (setf (characters-so-far progress-bar) showable) + (dotimes (i needed) + (write-char (progress-character progress-bar))) + (finish-output))) + +(defmethod update-progress (progress-bar unit-count) + (incf (pending progress-bar) unit-count) + (let ((now (get-internal-real-time))) + (when (< (update-interval progress-bar) + (- now (last-update-time progress-bar))) + (update-display progress-bar)))) + +(defmethod finish-display (progress-bar) + (update-display progress-bar) + (setf (end-time progress-bar) (get-internal-real-time)) + (terpri) + (format t "~:D bytes in ~$ seconds (~$KB/sec)" + (total progress-bar) + (elapsed-time progress-bar) + (/ (units-per-second progress-bar) 1024)) + (finish-output)) + +(defmethod elapsed-time (progress-bar) + (/ (- (end-time progress-bar) (start-time progress-bar)) + internal-time-units-per-second)) + +(defmethod units-per-second (progress-bar) + (if (plusp (elapsed-time progress-bar)) + (/ (total progress-bar) (elapsed-time progress-bar)) + 0)) + +(defun kb/sec (progress-bar) + (/ (units-per-second progress-bar) 1024)) + + + +(defparameter *uncertain-progress-chars* "?") + +(defclass uncertain-size-progress-bar (progress-bar) + ((progress-char-index + :initarg :progress-char-index + :accessor progress-char-index) + (units-per-char + :initarg :units-per-char + :accessor units-per-char)) + (:default-initargs + :total 0 + :progress-char-index 0 + :units-per-char (floor (expt 1024 2) 50))) + +(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) + unit-count) + (incf (total progress-bar) unit-count)) + +(defmethod progress-character ((progress-bar uncertain-size-progress-bar)) + (let ((index (progress-char-index progress-bar))) + (prog1 + (char *uncertain-progress-chars* index) + (setf (progress-char-index progress-bar) + (mod (1+ index) (length *uncertain-progress-chars*)))))) + +(defmethod update-display ((progress-bar uncertain-size-progress-bar)) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (multiple-value-bind (chars pend) + (floor (pending progress-bar) (units-per-char progress-bar)) + (setf (pending progress-bar) pend) + (dotimes (i chars) + (write-char (progress-character progress-bar)) + (incf (characters-so-far progress-bar)) + (when (<= (character-count progress-bar) + (characters-so-far progress-bar)) + (terpri) + (setf (characters-so-far progress-bar) 0) + (finish-output))) + (finish-output))) + +(defun make-progress-bar (total) + (if (or (not total) (zerop total)) + (make-instance 'uncertain-size-progress-bar) + (make-instance 'progress-bar :total total))) + +;;; +;;; A simple HTTP client +;;; + +(in-package #:qlqs-http) + +;;; Octet data + +(deftype octet () + '(unsigned-byte 8)) + +(defun make-octet-vector (size) + (make-array size :element-type 'octet + :initial-element 0)) + +(defun octet-vector (&rest octets) + (make-array (length octets) :element-type 'octet + :initial-contents octets)) + +;;; ASCII characters as integers + +(defun acode (char) + (cond ((eql char :cr) + 13) + ((eql char :lf) + 10) + (t + (let ((code (char-code char))) + (if (<= 0 code 127) + code + (error "Character ~S is not in the ASCII character set" + char)))))) + +(defvar *whitespace* + (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) + +(defun whitep (code) + (member code *whitespace*)) + +(defun ascii-vector (string) + (let ((vector (make-octet-vector (length string)))) + (loop for char across string + for code = (char-code char) + for i from 0 + if (< 127 code) do + (error "Invalid character for ASCII -- ~A" char) + else + do (setf (aref vector i) code)) + vector)) + +(defun ascii-subseq (vector start end) + "Return a subseq of octet-specialized VECTOR as a string." + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun ascii-downcase (code) + (if (<= 65 code 90) + (+ code 32) + code)) + +(defun ascii-equal (a b) + (eql (ascii-downcase a) (ascii-downcase b))) + +(defmacro acase (value &body cases) + (flet ((convert-case-keys (keys) + (mapcar (lambda (key) + (etypecase key + (integer key) + (character (char-code key)) + (symbol + (ecase key + (:cr 13) + (:lf 10) + ((t) t))))) + (if (consp keys) keys (list keys))))) + `(case ,value + ,@(mapcar (lambda (case) + (destructuring-bind (keys &rest body) + case + `(,(if (eql keys t) + t + (convert-case-keys keys)) + ,@body))) + cases)))) + +;;; Pattern matching (for finding headers) + +(defclass matcher () + ((pattern + :initarg :pattern + :reader pattern) + (pos + :initform 0 + :accessor match-pos) + (matchedp + :initform nil + :accessor matchedp))) + +(defun reset-match (matcher) + (setf (match-pos matcher) 0 + (matchedp matcher) nil)) + +(define-condition match-failure (error) ()) + +(defun match (matcher input &key (start 0) end error) + (let ((i start) + (end (or end (length input))) + (match-end (length (pattern matcher)))) + (with-slots (pattern pos) + matcher + (loop + (cond ((= pos match-end) + (let ((match-start (- i pos))) + (setf pos 0) + (setf (matchedp matcher) t) + (return (values match-start (+ match-start match-end))))) + ((= i end) + (return nil)) + ((= (aref pattern pos) + (aref input i)) + (incf i) + (incf pos)) + (t + (if error + (error 'match-failure) + (if (zerop pos) + (incf i) + (setf pos 0))))))))) + +(defun ascii-matcher (string) + (make-instance 'matcher + :pattern (ascii-vector string))) + +(defun octet-matcher (&rest octets) + (make-instance 'matcher + :pattern (apply 'octet-vector octets))) + +(defun acode-matcher (&rest codes) + (make-instance 'matcher + :pattern (make-array (length codes) + :element-type 'octet + :initial-contents + (mapcar 'acode codes)))) + + +;;; "Connection Buffers" are a kind of callback-driven, +;;; pattern-matching chunky stream. Callbacks can be called for a +;;; certain number of octets or until one or more patterns are seen in +;;; the input. cbufs automatically refill themselves from a +;;; connection as needed. + +(defvar *cbuf-buffer-size* 8192) + +(define-condition end-of-data (error) ()) + +(defclass cbuf () + ((data + :initarg :data + :accessor data) + (connection + :initarg :connection + :accessor connection) + (start + :initarg :start + :accessor start) + (end + :initarg :end + :accessor end) + (eofp + :initarg :eofp + :accessor eofp)) + (:default-initargs + :data (make-octet-vector *cbuf-buffer-size*) + :connection nil + :start 0 + :end 0 + :eofp nil) + (:documentation "A CBUF is a connection buffer that keeps track of + incoming data from a connection. Several functions make it easy to + treat a CBUF as a kind of chunky, callback-driven stream.")) + +(define-condition cbuf-progress () + ((size + :initarg :size + :accessor cbuf-progress-size + :initform 0))) + +(defun call-processor (fun cbuf start end) + (signal 'cbuf-progress :size (- end start)) + (funcall fun (data cbuf) start end)) + +(defun make-cbuf (connection) + (make-instance 'cbuf :connection connection)) + +(defun make-stream-writer (stream) + "Create a callback for writing data to STREAM." + (lambda (data start end) + (write-sequence data stream :start start :end end))) + +(defgeneric size (cbuf) + (:method ((cbuf cbuf)) + (- (end cbuf) (start cbuf)))) + +(defgeneric emptyp (cbuf) + (:method ((cbuf cbuf)) + (zerop (size cbuf)))) + +(defgeneric refill (cbuf) + (:method ((cbuf cbuf)) + (when (eofp cbuf) + (error 'end-of-data)) + (setf (start cbuf) 0) + (setf (end cbuf) + (read-octets (data cbuf) + (connection cbuf))) + (cond ((emptyp cbuf) + (setf (eofp cbuf) t) + (error 'end-of-data)) + (t (size cbuf))))) + +(defun process-all (fun cbuf) + (unless (emptyp cbuf) + (call-processor fun cbuf (start cbuf) (end cbuf)))) + +(defun multi-cmatch (matchers cbuf) + (let (start end) + (dolist (matcher matchers (values start end)) + (multiple-value-bind (s e) + (match matcher (data cbuf) + :start (start cbuf) + :end (end cbuf)) + (when (and s (or (null start) (< s start))) + (setf start s + end e)))))) + +(defun cmatch (matcher cbuf) + (if (consp matcher) + (multi-cmatch matcher cbuf) + (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) + +(defun call-until-end (fun cbuf) + (handler-case + (loop + (process-all fun cbuf) + (refill cbuf)) + (end-of-data () + (return-from call-until-end)))) + +(defun show-cbuf (context cbuf) + (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) + +(defun call-for-n-octets (n fun cbuf) + (let ((remaining n)) + (loop + (when (<= remaining (size cbuf)) + (let ((end (+ (start cbuf) remaining))) + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (decf remaining (size cbuf)) + (refill cbuf)))) + +(defun call-until-matching (matcher fun cbuf) + (loop + (multiple-value-bind (start end) + (cmatch matcher cbuf) + (when start + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (refill cbuf))) + +(defun ignore-data (data start end) + (declare (ignore data start end))) + +(defun skip-until-matching (matcher cbuf) + (call-until-matching matcher 'ignore-data cbuf)) + + +;;; Creating HTTP requests as octet buffers + +(defclass octet-sink () + ((storage + :initarg :storage + :accessor storage)) + (:default-initargs + :storage (make-array 1024 :element-type 'octet + :fill-pointer 0 + :adjustable t)) + (:documentation "A simple stream-like target for collecting + octets.")) + +(defun add-octet (octet sink) + (vector-push-extend octet (storage sink))) + +(defun add-octets (octets sink &key (start 0) end) + (setf end (or end (length octets))) + (loop for i from start below end + do (add-octet (aref octets i) sink))) + +(defun add-string (string sink) + (loop for char across string + for code = (char-code char) + do (add-octet code sink))) + +(defun add-strings (sink &rest strings) + (mapc (lambda (string) (add-string string sink)) strings)) + +(defun add-newline (sink) + (add-octet 13 sink) + (add-octet 10 sink)) + +(defun sink-buffer (sink) + (subseq (storage sink) 0)) + +(defvar *proxy-url* nil) + +(defun full-proxy-path (host port path) + (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" + (= port 443) + host + (or (= port 80) + (= port 443)) + port + path)) + +(defun make-request-buffer (host port path &key (method "GET")) + (setf method (string method)) + (when *proxy-url* + (setf path (full-proxy-path host port path))) + (let ((sink (make-instance 'octet-sink))) + (flet ((add-line (&rest strings) + (apply #'add-strings sink strings) + (add-newline sink))) + (add-line method " " path " HTTP/1.1") + (add-line "Host: " host (if (= port 80) "" + (format nil ":~D" port))) + (add-line "Connection: close") + ;; FIXME: get this version string from somewhere else. + (add-line "User-Agent: quicklisp-bootstrap/" + qlqs-info:*version*) + (add-newline sink) + (sink-buffer sink)))) + +(defun sink-until-matching (matcher cbuf) + (let ((sink (make-instance 'octet-sink))) + (call-until-matching + matcher + (lambda (buffer start end) + (add-octets buffer sink :start start :end end)) + cbuf) + (sink-buffer sink))) + + +;;; HTTP headers + +(defclass header () + ((data + :initarg :data + :accessor data) + (status + :initarg :status + :accessor status) + (name-starts + :initarg :name-starts + :accessor name-starts) + (name-ends + :initarg :name-ends + :accessor name-ends) + (value-starts + :initarg :value-starts + :accessor value-starts) + (value-ends + :initarg :value-ends + :accessor value-ends))) + +(defmethod print-object ((header header) stream) + (print-unreadable-object (header stream :type t) + (prin1 (status header) stream))) + +(defun matches-at (pattern target pos) + (= (mismatch pattern target :start2 pos) (length pattern))) + +(defun header-value-indexes (field-name header) + (loop with data = (data header) + with pattern = (ascii-vector (string-downcase field-name)) + for start across (name-starts header) + for i from 0 + when (matches-at pattern data start) + return (values (aref (value-starts header) i) + (aref (value-ends header) i)))) + +(defun ascii-header-value (field-name header) + (multiple-value-bind (start end) + (header-value-indexes field-name header) + (when start + (ascii-subseq (data header) start end)))) + +(defun all-field-names (header) + (map 'list + (lambda (start end) + (ascii-subseq (data header) start end)) + (name-starts header) + (name-ends header))) + +(defun headers-alist (header) + (mapcar (lambda (name) + (cons name (ascii-header-value name header))) + (all-field-names header))) + +(defmethod describe-object :after ((header header) stream) + (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) + +(defun content-length (header) + (let ((field-value (ascii-header-value "content-length" header))) + (when field-value + (let ((value (ignore-errors (parse-integer field-value)))) + (or value + (error "Content-Length header field value is not a number -- ~A" + field-value)))))) + +(defun chunkedp (header) + (string= (ascii-header-value "transfer-encoding" header) "chunked")) + +(defun location (header) + (ascii-header-value "location" header)) + +(defun status-code (vector) + (let* ((space (position (acode #\Space) vector)) + (c1 (- (aref vector (incf space)) 48)) + (c2 (- (aref vector (incf space)) 48)) + (c3 (- (aref vector (incf space)) 48))) + (+ (* c1 100) + (* c2 10) + (* c3 1)))) + +(defun force-downcase-field-names (header) + (loop with data = (data header) + for start across (name-starts header) + for end across (name-ends header) + do (loop for i from start below end + for code = (aref data i) + do (setf (aref data i) (ascii-downcase code))))) + +(defun skip-white-forward (pos vector) + (position-if-not 'whitep vector :start pos)) + +(defun skip-white-backward (pos vector) + (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) + (if nonwhite + (1+ nonwhite) + pos))) + +(defun contract-field-value-indexes (header) + "Header field values exclude leading and trailing whitespace; adjust +the indexes in the header accordingly." + (loop with starts = (value-starts header) + with ends = (value-ends header) + with data = (data header) + for i from 0 + for start across starts + for end across ends + do + (setf (aref starts i) (skip-white-forward start data)) + (setf (aref ends i) (skip-white-backward end data)))) + +(defun next-line-pos (vector) + (let ((pos 0)) + (labels ((finish (&optional (i pos)) + (return-from next-line-pos i)) + (after-cr (code) + (acase code + (:lf (finish pos)) + (t (finish (1- pos))))) + (pending (code) + (acase code + (:cr #'after-cr) + (:lf (finish pos)) + (t #'pending)))) + (let ((state #'pending)) + (loop + (setf state (funcall state (aref vector pos))) + (incf pos)))))) + +(defun make-hvector () + (make-array 16 :fill-pointer 0 :adjustable t)) + +(defun process-header (vector) + "Create a HEADER instance from the octet data in VECTOR." + (let* ((name-starts (make-hvector)) + (name-ends (make-hvector)) + (value-starts (make-hvector)) + (value-ends (make-hvector)) + (header (make-instance 'header + :data vector + :status 999 + :name-starts name-starts + :name-ends name-ends + :value-starts value-starts + :value-ends value-ends)) + (mark nil) + (pos (next-line-pos vector))) + (unless pos + (error "Unable to process HTTP header")) + (setf (status header) (status-code vector)) + (labels ((save (value vector) + (vector-push-extend value vector)) + (mark () + (setf mark pos)) + (clear-mark () + (setf mark nil)) + (finish () + (if mark + (save mark value-ends) + (save pos value-ends)) + (force-downcase-field-names header) + (contract-field-value-indexes header) + (return-from process-header header)) + (in-new-line (code) + (acase code + ((#\Tab #\Space) (setf mark nil) #'in-value) + (t + (when mark + (save mark value-ends)) + (clear-mark) + (save pos name-starts) + (in-name code)))) + (after-cr (code) + (acase code + (:lf #'in-new-line) + (t (in-new-line code)))) + (pending-value (code) + (acase code + ((#\Tab #\Space) #'pending-value) + (:cr #'after-cr) + (:lf #'in-new-line) + (t (save pos value-starts) #'in-value))) + (in-name (code) + (acase code + (#\: + (save pos name-ends) + (save (1+ pos) value-starts) + #'in-value) + ((:cr :lf) + (finish)) + ((#\Tab #\Space) + (error "Unexpected whitespace in header field name")) + (t + (unless (<= 0 code 127) + (error "Unexpected non-ASCII header field name")) + #'in-name))) + (in-value (code) + (acase code + (:lf (mark) #'in-new-line) + (:cr (mark) #'after-cr) + (t #'in-value)))) + (let ((state #'in-new-line)) + (loop + (incf pos) + (when (<= (length vector) pos) + (error "No header found in response")) + (setf state (funcall state (aref vector pos)))))))) + + +;;; HTTP URL parsing + +(defclass url () + ((hostname + :initarg :hostname + :accessor hostname + :initform nil) + (port + :initarg :port + :accessor port + :initform 80) + (path + :initarg :path + :accessor path + :initform "/"))) + +(defun parse-urlstring (urlstring) + (setf urlstring (string-trim " " urlstring)) + (let* ((pos (mismatch urlstring "http://" :test 'char-equal)) + (mark pos) + (url (make-instance 'url))) + (labels ((save () + (subseq urlstring mark pos)) + (mark () + (setf mark pos)) + (finish () + (return-from parse-urlstring url)) + (hostname-char-p (char) + (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." + :test 'char-equal)) + (at-start (char) + (case char + (#\/ + (setf (port url) nil) + (mark) + #'in-path) + (t + #'in-host))) + (in-host (char) + (case char + ((#\/ :end) + (setf (hostname url) (save)) + (mark) + #'in-path) + (#\: + (setf (hostname url) (save)) + (mark) + #'in-port) + (t + (unless (hostname-char-p char) + (error "~S is not a valid URL" urlstring)) + #'in-host))) + (in-port (char) + (case char + ((#\/ :end) + (setf (port url) + (parse-integer urlstring + :start (1+ mark) + :end pos)) + (mark) + #'in-path) + (t + (unless (digit-char-p char) + (error "Bad port in URL ~S" urlstring)) + #'in-port))) + (in-path (char) + (case char + ((#\# :end) + (setf (path url) (save)) + (finish))) + #'in-path)) + (let ((state #'at-start)) + (loop + (when (<= (length urlstring) pos) + (funcall state :end) + (finish)) + (setf state (funcall state (aref urlstring pos))) + (incf pos)))))) + +(defun url (thing) + (if (stringp thing) + (parse-urlstring thing) + thing)) + +(defgeneric request-buffer (method url) + (:method (method url) + (setf url (url url)) + (make-request-buffer (hostname url) (port url) (path url) + :method method))) + +(defun urlstring (url) + (format nil "~@[http://~A~]~@[:~D~]~A" + (hostname url) + (and (/= 80 (port url)) (port url)) + (path url))) + +(defmethod print-object ((url url) stream) + (print-unreadable-object (url stream :type t) + (prin1 (urlstring url) stream))) + +(defun merge-urls (url1 url2) + (setf url1 (url url1)) + (setf url2 (url url2)) + (make-instance 'url + :hostname (or (hostname url1) + (hostname url2)) + :port (or (port url1) + (port url2)) + :path (or (path url1) + (path url2)))) + + +;;; Requesting an URL and saving it to a file + +(defparameter *maximum-redirects* 10) +(defvar *default-url-defaults* (url "http://src.quicklisp.org/")) + +(defun read-http-header (cbuf) + (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) + (acode-matcher :cr :cr) + (acode-matcher :cr :lf :cr :lf)) + cbuf))) + (process-header header-data))) + +(defun read-chunk-header (cbuf) + (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) + (end (or (position (acode :cr) header-data) + (position (acode #\;) header-data)))) + (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) + +(defun save-chunk-response (stream cbuf) + "For a chunked response, read all chunks and write them to STREAM." + (let ((fun (make-stream-writer stream)) + (matcher (acode-matcher :cr :lf))) + (loop + (let ((chunk-size (read-chunk-header cbuf))) + (when (zerop chunk-size) + (return)) + (call-for-n-octets chunk-size fun cbuf) + (skip-until-matching matcher cbuf))))) + +(defun save-response (file header cbuf) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :element-type 'octet) + (let ((content-length (content-length header))) + (cond ((chunkedp header) + (save-chunk-response stream cbuf)) + (content-length + (call-for-n-octets content-length + (make-stream-writer stream) + cbuf)) + (t + (call-until-end (make-stream-writer stream) cbuf)))))) + +(defun call-with-progress-bar (size fun) + (let ((progress-bar (make-progress-bar size))) + (start-display progress-bar) + (flet ((update (condition) + (update-progress progress-bar + (cbuf-progress-size condition)))) + (handler-bind ((cbuf-progress #'update)) + (funcall fun))) + (finish-display progress-bar))) + +(defun fetch (url file &key (follow-redirects t) quietly + (maximum-redirects *maximum-redirects*)) + "Request URL and write the body of the response to FILE." + (setf url (merge-urls url *default-url-defaults*)) + (setf file (merge-pathnames file)) + (let ((redirect-count 0) + (original-url url) + (connect-url (or (url *proxy-url*) url)) + (stream (if quietly + (make-broadcast-stream) + *trace-output*))) + (loop + (when (<= maximum-redirects redirect-count) + (error "Too many redirects for ~A" original-url)) + (with-connection (connection (hostname connect-url) (port connect-url)) + (let ((cbuf (make-instance 'cbuf :connection connection)) + (request (request-buffer "GET" url))) + (write-octets request connection) + (let ((header (read-http-header cbuf))) + (loop while (= (status header) 100) + do (setf header (read-http-header cbuf))) + (cond ((= (status header) 200) + (let ((size (content-length header))) + (format stream "~&; Fetching ~A~%" url) + (if (and (numberp size) + (plusp size)) + (format stream "; ~$KB~%" (/ size 1024)) + (format stream "; Unknown size~%")) + (if quietly + (save-response file header cbuf) + (call-with-progress-bar (content-length header) + (lambda () + (save-response file header cbuf)))))) + ((not (<= 300 (status header) 399)) + (error "Unexpected status for ~A: ~A" + url (status header)))) + (if (and follow-redirects (<= 300 (status header) 399)) + (let ((new-urlstring (ascii-header-value "location" header))) + (when (not new-urlstring) + (error "Redirect code ~D received, but no Location: header" + (status header))) + (incf redirect-count) + (setf url (merge-urls new-urlstring + url)) + (format stream "~&; Redirecting to ~A~%" url)) + (return (values header (and file (probe-file file))))))))))) + + +;;; A primitive tar unpacker + +(in-package #:qlqs-minitar) + +(defun make-block-buffer () + (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0)) + +(defun skip-n-blocks (n stream) + (let ((block (make-block-buffer))) + (dotimes (i n) + (read-sequence block stream)))) + +(defun ascii-subseq (vector start end) + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun block-asciiz-string (block start length) + (let* ((end (+ start length)) + (eos (or (position 0 block :start start :end end) + end))) + (ascii-subseq block start eos))) + +(defun prefix (header) + (when (plusp (aref header 345)) + (block-asciiz-string header 345 155))) + +(defun name (header) + (block-asciiz-string header 0 100)) + +(defun payload-size (header) + (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) + +(defun nth-block (n file) + (with-open-file (stream file :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (skip-n-blocks (1- n) stream) + (read-sequence block stream) + block))) + +(defun payload-type (code) + (case code + (0 :file) + (48 :file) + (53 :directory) + (t :unsupported))) + +(defun full-path (header) + (let ((prefix (prefix header)) + (name (name header))) + (if prefix + (format nil "~A/~A" prefix name) + name))) + +(defun save-file (file size stream) + (multiple-value-bind (full-blocks partial) + (truncate size 512) + (ensure-directories-exist file) + (with-open-file (outstream file + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (dotimes (i full-blocks) + (read-sequence block stream) + (write-sequence block outstream)) + (when (plusp partial) + (read-sequence block stream) + (write-sequence block outstream :end partial)))))) + +(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) + (let ((block (make-block-buffer))) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return)) + (unless (= size 512) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return)) + (let* ((payload-code (aref block 156)) + (payload-type (payload-type payload-code)) + (tar-path (full-path block)) + (full-path (merge-pathnames tar-path directory)) + (payload-size (payload-size block))) + (case payload-type + (:file + (save-file full-path payload-size stream)) + (:directory + (ensure-directories-exist full-path)) + (t + (warn "Unknown tar block payload code -- ~D" payload-code) + (skip-n-blocks (ceiling (payload-size block) 512) stream))))))))) + +(defun contents (tarfile) + (let ((block (make-block-buffer)) + (result '())) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return (nreverse result))) + (unless (= size 512) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return (nreverse result))) + (let* ((payload-type (payload-type (aref block 156))) + (tar-path (full-path block)) + (payload-size (payload-size block))) + (skip-n-blocks (ceiling payload-size 512) stream) + (case payload-type + (:file + (push tar-path result)) + (:directory + (push tar-path result))))))))) + + +;;; +;;; The actual bootstrapping work +;;; + +(in-package #:quicklisp-quickstart) + +(defvar *home* + (merge-pathnames (make-pathname :directory '(:relative "quicklisp")) + (user-homedir-pathname))) + +(defun qmerge (pathname) + (merge-pathnames pathname *home*)) + +(defun renaming-fetch (url file) + (let ((tmpfile (qmerge "tmp/fetch.dat"))) + (fetch url tmpfile) + (rename-file tmpfile file))) + +(defvar *quickstart-parameters* nil + "This plist is populated with parameters that may carry over to the + initial configuration of the client, e.g. :proxy-url + or :initial-dist-url") + +(defvar *quicklisp-hostname* "beta.quicklisp.org") + +(defvar *client-info-url* + (format nil "http://~A/client/quicklisp.sexp" + *quicklisp-hostname*)) + +(defclass client-info () + ((setup-url + :reader setup-url + :initarg :setup-url) + (asdf-url + :reader asdf-url + :initarg :asdf-url) + (client-tar-url + :reader client-tar-url + :initarg :client-tar-url) + (version + :reader version + :initarg :version) + (plist + :reader plist + :initarg :plist) + (source-file + :reader source-file + :initarg :source-file))) + +(defmethod print-object ((client-info client-info) stream) + (print-unreadable-object (client-info stream :type t) + (prin1 (version client-info) stream))) + +(defun safely-read (stream) + (let ((*read-eval* nil)) + (read stream))) + +(defun fetch-client-info-plist (url) + "Fetch and return the client info data at URL." + (let ((local-client-info-file (qmerge "tmp/client-info.sexp"))) + (ensure-directories-exist local-client-info-file) + (renaming-fetch url local-client-info-file) + (with-open-file (stream local-client-info-file) + (list* :source-file local-client-info-file + (safely-read stream))))) + +(defun fetch-client-info (url) + (let ((plist (fetch-client-info-plist url))) + (destructuring-bind (&key setup asdf client-tar version + source-file + &allow-other-keys) + plist + (unless (and setup asdf client-tar version) + (error "Invalid data from client info URL -- ~A" url)) + (make-instance 'client-info + :setup-url (getf setup :url) + :asdf-url (getf asdf :url) + :client-tar-url (getf client-tar :url) + :version version + :plist plist + :source-file source-file)))) + +(defun client-info-url-from-version (version) + (format nil "http://~A/client/~A/client-info.sexp" + *quicklisp-hostname* + version)) + +(defun distinfo-url-from-version (version) + (format nil "http://~A/dist/~A/distinfo.txt" + *quicklisp-hostname* + version)) + +(defvar *help-message* + (format nil "~&~% ==== quicklisp quickstart install help ====~%~% ~ + quicklisp-quickstart:install can take the following ~ + optional arguments:~%~% ~ + :path \"/path/to/installation/\"~%~% ~ + :proxy \"http://your.proxy:port/\"~%~% ~ + :client-url ~%~% ~ + :client-version ~%~% ~ + :dist-url ~%~% ~ + :dist-version ~%~%")) + +(defvar *after-load-message* + (format nil "~&~% ==== quicklisp quickstart ~A loaded ====~%~% ~ + To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~ + For installation options, evaluate: (quicklisp-quickstart:help)~%~%" + qlqs-info:*version*)) + +(defvar *after-initial-setup-message* + (with-output-to-string (*standard-output*) + (format t "~&~% ==== quicklisp installed ====~%~%") + (format t " To load a system, use: (ql:quickload \"system-name\")~%~%") + (format t " To find systems, use: (ql:system-apropos \"term\")~%~%") + (format t " To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%") + (format t " For more information, see http://www.quicklisp.org/beta/~%~%"))) + +(defun initial-install (&key (client-url *client-info-url*) dist-url) + (setf *quickstart-parameters* + (list :proxy-url *proxy-url* + :initial-dist-url dist-url)) + (ensure-directories-exist (qmerge "tmp/")) + (let ((client-info (fetch-client-info client-url)) + (tmptar (qmerge "tmp/quicklisp.tar")) + (setup (qmerge "setup.lisp")) + (asdf (qmerge "asdf.lisp"))) + (renaming-fetch (client-tar-url client-info) tmptar) + (unpack-tarball tmptar :directory (qmerge "./")) + (renaming-fetch (setup-url client-info) setup) + (renaming-fetch (asdf-url client-info) asdf) + (rename-file (source-file client-info) (qmerge "client-info.sexp")) + (load setup :verbose nil :print nil) + (write-string *after-initial-setup-message*) + (finish-output))) + +(defun help () + (write-string *help-message*) + t) + +(defun non-empty-file-namestring (pathname) + (let ((string (file-namestring pathname))) + (unless (or (null string) + (equal string "")) + string))) + +(defun install (&key ((:path *home*) *home*) + ((:proxy *proxy-url*) *proxy-url*) + client-url + client-version + dist-url + dist-version) + (setf *home* (merge-pathnames *home* (truename *default-pathname-defaults*))) + (let ((name (non-empty-file-namestring *home*))) + (when name + (warn "Making ~A part of the install pathname directory" + name) + ;; This corrects a pathname like "/foo/bar" to "/foo/bar/" and + ;; "foo" to "foo/" + (setf *home* + (make-pathname :defaults *home* + :directory (append (pathname-directory *home*) + (list name)))))) + (let ((setup-file (qmerge "setup.lisp"))) + (when (probe-file setup-file) + (multiple-value-bind (result proceed) + (with-simple-restart (load-setup "Load ~S" setup-file) + (error "Quicklisp has already been installed. Load ~S instead." + setup-file)) + (declare (ignore result)) + (when proceed + (return-from install (load setup-file)))))) + (if (find-package '#:ql) + (progn + (write-line "!!! Quicklisp has already been set up. !!!") + (write-string *after-initial-setup-message*) + t) + (call-with-quiet-compilation + (lambda () + (let ((client-url (or client-url + (and client-version + (client-info-url-from-version client-version)) + *client-info-url*)) + ;; It's ok for dist-url to be nil; there's a default in + ;; the client + (dist-url (or dist-url + (and dist-version + (distinfo-url-from-version dist-version))))) + (initial-install :client-url client-url + :dist-url dist-url)))))) + +(write-string *after-load-message*) + +;;; End of quicklisp.lisp diff --git a/sat.lisp b/sat.lisp new file mode 100644 index 0000000..3cdfd9a --- /dev/null +++ b/sat.lisp @@ -0,0 +1,36 @@ +(load "utils.lisp") + +(defun first-n-bits (n int) + (loop for i below n + collecting (logbitp i int))) + +(defun sat (expr) + (let* ((vars (delete-duplicates + (remove-if (lambda (x) (inq x and or not xor t nil)) + (flatten expr)))) + (varc (length vars)) + (f (eval `(lambda ,vars + (declare (type boolean ,@vars) (optimize (speed 3) (safety 0) (debug 0))) + ,expr)))) + (disassemble f) + (loop for n below (expt 2 varc) + do (let1 bits (first-n-bits varc n) + (when (apply f bits) + (return-from sat + (mapcar #'list vars bits))))) + :unsat)) + +(defmacro time-s (expr) + (with-gensyms (start end diff) + `(begin + (= ,start (get-internal-real-time)) + ,expr + (= ,end (get-internal-real-time)) + (= ,diff (- ,end ,start)) + (/ ,diff internal-time-units-per-second)))) + +(defparameter timings + (loop for var-count below 30 + collecting + (time-s (sat `(and ,@(loop for i below var-count + collecting (symb 'v i))))))) diff --git a/to-desmos.lisp b/to-desmos.lisp new file mode 100644 index 0000000..d47ffa8 --- /dev/null +++ b/to-desmos.lisp @@ -0,0 +1,30 @@ +(load "utils.lisp") + +(defgeneric to-desmos (obj port) + (:documentation "write OBJ in desmos-flavored latex to PORT")) + +(defmethod to-desmos ((obj complex) port) + (to-desmos (realpart obj) port) + (write-char #\+ port) + (to-desmos (imagpart obj) port) + (write-char #\i port)) + +(defmethod to-desmos ((obj real) port) + (format port "~f" obj)) + +(defmethod to-desmos ((obj rational) port) + (format port "\\frac{") + (to-desmos (numerator obj) port) + (format port "}{") + (to-desmos (denominator obj) port) + (format port "}")) + +(defmethod to-desmos ((obj integer) port) + (format port "~d" obj)) + +(defmethod to-desmos ((obj list) port) + (format port "\\left[") + (loop for (n . rest) on obj + do (to-desmos n port) + when rest do (format port ",")) + (format port "\\right]")) diff --git a/undesirable-macros.lisp b/undesirable-macros.lisp new file mode 100644 index 0000000..1a09d56 --- /dev/null +++ b/undesirable-macros.lisp @@ -0,0 +1,29 @@ +(load "utils.lisp") + +(defmacro fstr (str) + (begin + (= cmd nil) + (= outstr (gensym "outstr")) + (=f emit (c) (push `(princ ,c ,outstr) cmd)) + (with-input-from-string (s str) + (loop with escaping? = nil + for c = (read-char s nil nil) + while c + do (cond + (escaping? (emit c) + (setf escaping? nil)) + (t (match c + (#\\ (setf escaping? t)) + (#\{ + (begin + (= chars + (loop for c = (read-char s nil nil) + while c + until (eql c #\}) + collecting c)) + (= str (map 'string #'identity chars)) + (emit (read-from-string str)))) + (_ (emit c))))))) + `(with-output-to-string (,outstr) + ,@(nreverse cmd)))) + diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..ab0a37a --- /dev/null +++ b/utils.lisp @@ -0,0 +1,698 @@ +;;; fun +(proclaim '(inline last1 single append1 conc1)) + +;; has a lot of goodies +;; hey whaddayaknow, pg has a with-gensyms +;; it's just such a useful pattern +;; maybe i should go wild with the defmacro!?g stuff from LOL + +(defun last1 (lst) + (car (last lst))) + +(defun single (lst) + (and (consp lst) (not (cdr lst)))) + +(defun append1 (lst obj) + (append lst (list obj))) + +(defun conc1 (lst obj) + (nconc lst (list obj))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload '("alexandria" "trivia") :silent t) + (use-package '(:alexandria :trivia)) + + (proclaim '(inline mklist)) + + (defun mklist (obj) + (if (listp obj) obj (list obj))) + + (defmacro let1 (name val &body body) + `(let ((,name ,val)) + ,@body)) + + ;; labels should rarely be needed + (defmacro fpromote ((&rest fs) &body body) + `(labels ,(loop for f in (mklist fs) + collecting + (let ((fname + (if (listp f) + (car f) + f)) + (fval + (if (listp f) + (cadr f) + f)) + (xs (gensym "args"))) + `(,fname (&rest ,xs) (apply ,fval ,xs)))) + ,@body)) + + (defmacro nlet (name (&rest vars) &body body) + (let1 vars (mapcar #'mklist vars) + `(labels ((,name ,(mapcar #'car vars) ,@body)) + (,name ,@(mapcar #'cadr vars))))) + + (defun group (source n) + (if (zerop n) (error "zero length")) + (labels ((rec (source acc) + (let1 rest (nthcdr n source) + (if (consp rest) + (rec rest (cons (subseq source 0 n) acc)) + (nreverse (cons source acc)))))) + (if source (rec source nil) nil))) + + (defmacro cond1 (&body branches) + `(cond ,@(mapcar (lambda (x) + (if (cdr x) + x + (cons t x))) + (group branches 2)))) + (defmacro when-bind ((var expr) &body body) + `(let ((,var ,expr)) + (when ,var + ,@body))) + + (defmacro when-bind* (binds &body body) + (if (null binds) + `(progn ,@body) + `(let (,(car binds)) + (if ,(caar binds) + (when-bind* ,(cdr binds) ,@body))))) + + (defun condlet-binds (vars cl) + (mapcar #'(lambda (bindform) + (if (consp bindform) + (cons (cdr (assoc (car bindform) vars)) + (cdr bindform)))) + (cdr cl))) + + (defun condlet-clause (vars cl bodfn) + `(,(car cl) (let ,(mapcar #'cdr vars) + (let ,(condlet-binds vars cl) + (,bodfn ,@(mapcar #'cdr vars)))))) + + ;; straight up do not get this one + #+(or) + (defmacro condlet (clauses &body body) + (let ((bodfn (gensym)) + (vars (mapcar #'(lambda (v) (cons v (gensym))) + (remove-duplicates + (mapcar #'car + (mappend #'cdr clauses)))))) + `(labels ((,bodfn ,(mapcar #'car vars) + ,@body)) + (cond ,@ (mapcar #'(lambda (cl) + (condlet-clause vars cl bodfn)) + clauses)))))) + +(defun longer (x y) + (labels ((compare (x y) + (and (consp x) + (or (null y) + (compare (cdr x) (cdr y)))))) + (if (and (listp x) (listp y)) + (compare x y) + (> (length x) (length y))))) + +(defun filter (f lst) + (fpromote f + (let (acc) + (dolist (x lst) + (let1 val (f x) + (if val (push val acc)))) + (nreverse acc)))) + +(defun prune (test tree) + (fpromote test + (labels ((rec (tree acc) + (cond1 + (null tree) (nreverse acc) + (consp (car tree)) (rec (cdr tree) + (cons (rec (car tree) nil) acc)) + (rec (cdr tree) + (if (test (car tree)) + acc + (cons (car tree) acc)))))) + (rec tree nil)))) + +(defun find2 (f lst) + (fpromote f + (if (null lst) + nil + (let1 val (f (car lst)) + (if val + (values (car lst) val) + (find2 f (cdr lst))))))) + +(defun before (x y lst &key (test #'eql)) + (fpromote test + (and lst + (let1 first (car lst) + (cond1 + (test y first) nil + (test x first) lst + (before x y (cdr lst) :test test)))))) + +(defun after (x y lst &key (test #'eql)) + (let1 rest (before y x lst :test test) + (and rest (member x rest :test test)))) + +(defun duplicate (obj lst &key (test #'eql)) + (member obj (cdr (member obj lst :test test)) + :test test)) + +(defun split-if (f lst) + (fpromote f + (let (acc) + (do ((src lst (cdr src))) + ((or (null src) (f (car src))) + (values (nreverse acc) src)) + (push (car src) acc))))) + +(defun most (f lst) + (fpromote f + (if (null lst) + (values nil nil) + (let* ((wins (car lst)) + (max (f wins))) + (dolist (obj (cdr lst)) + (let1 score (f obj) + (when (> score max) + (setf wins obj + max score)))) + (values wins max))))) + +(defun best (f lst) + (fpromote f + (if (null lst) + nil + (let1 wins (car lst) + (dolist (obj (cdr lst)) + (if (f obj wins) + (setf wins obj))) + wins)))) + +(defun mostn (f lst) + (fpromote f + (if (null lst) + (values nil nil) + (let ((result (list (car lst))) + (max (f (car lst)))) + (dolist (obj (cdr lst)) + (let1 score (f obj) + (cond1 + (> score max) (setf max score + result (list obj)) + (= score max) (push obj result)))) + (values (nreverse result) max))))) + +(defun mapa-b (f a b &optional (step 1)) + (fpromote f + (do ((i a (+ i step)) + (result nil)) + ((> i b) (nreverse result)) + (push (f i) result)))) + +(defun map0-n (f n) + (mapa-b f 0 n)) + +(defun map1-n (f n) + (mapa-b f 1 n)) + +(defun map-> (f start test succ) + (fpromote (f test succ) + (do ((i start (succ i)) + (result nil)) + ((test i) (nreverse result)) + (push (f i) result)))) + +(defun mapcars (f &rest lsts) + (fpromote f + (let (result) + (dolist (lst lsts) + (dolist (obj lst) + (push (f obj) result))) + (nreverse result)))) + +(defun rmapcar (f &rest args) + (if (some #'atom args) + (apply f args) + (apply #'mapcar + #'(lambda (&rest args) + (apply #'rmapcar f args)) + args))) + +(defun readlist (&rest args) + (values (read-from-string + (concatenate 'string + "(" + (apply #'read-line args) + ")")))) + +(defun prompt (&rest args) + (apply #'format *query-io* args) + (read *query-io*)) + +(defun break-loop (f quit &rest args) + (format *query-io* "Entering break-loop ~%") + (loop + (let1 in (apply #'prompt args) + (if (funcall quit in) + (return) + (format *query-io* "~a~%" (funcall f in)))))) + +(defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + +(defun symb (&rest args) + (values (intern (apply #'mkstr args)))) + +(defun reread (&rest args) + (values (read-from-string (apply #'mkstr args)))) + +;; likely undesirable +(defun explode (sym) + (map 'list #'(lambda (c) + (intern (make-string 1 :initial-element c))) + (symbol-name sym))) + +;; do we want this? +;; (defvar *!equivs* (make-hash-table)) +;; +;; (defun ! (fn) +;; (or (gethash fn *!equivs*) fn)) +;; +;; (defun def! (fn fn!) +;; (setf (gethash fn *!equivs*) fn!)) +;; +;; (def! #'remove-if #'delete-if) + +(defun memoize (f) + (let1 cache (make-hash-table :test #'equal) + #'(lambda (&rest args) + (multiple-value-bind (val win) (gethash args cache) + (if win + val + (setf (gethash args cache) + (apply f args))))))) + +;; yes +;; (defun compose (&rest fs) +;; (if fs +;; (let ((f1 (last1 fs)) +;; (fs (butlast fs))) +;; #'(lambda (&rest args) +;; (reduce #'funcall fs +;; :from-end t +;; :initial-value (apply f1 args)))) +;; #'identity)) + +;; maybe should take &rest args? +(defun fif (ifp then &optional else) + (fpromote (ifp then else) + #'(lambda (x) + (if (ifp x) + (then x) + (if else (else x)))))) + +;; f-intersection +(defun fint (f &rest fs) + (if (null fs) + f + (let1 chain (apply #'fint fs) + (fpromote (f chain) + #'(lambda (x) + (and (f x) (chain x))))))) + +;; f-union +(defun fun (f &rest fs) + (if (null fs) + f + (let1 chain (apply #'fun fs) + (fpromote (f chain) + #'(lambda (x) + (or (f x) (chain x))))))) + +(defun lrec (rec &optional base) + (fpromote (rec base) + (labels ((self (lst) + (if (null lst) + (if (functionp base) + (base) + base) + (rec (car lst) + #'(lambda () + (self (cdr lst))))))) + #'self))) + +(defun ttrav (rec &optional (base #'identity)) + (fpromote (rec base) + (labels ((self (tree) + (if (atom tree) + (if (functionp base) + (base tree) + base) + (rec (self (car tree)) + (if (cdr tree) + (self (cdr tree))))))) + #'self))) + +(defun trec (rec &optional (base #'identity)) + (fpromote (rec base) + (labels + ((self (tree) + (if (atom tree) + (if (functionp base) + (base tree) + base) + (rec tree + #'(lambda () (self (car tree))) + #'(lambda () + (if (cdr tree) + (self (cdr tree)))))))) + #'self))) + +(defmacro nil! (&rest vars) + `(setf ,@(loop for var in vars + nconcing (list var nil)))) + +(defmacro nif (n &optional pos zer neg) + (once-only (n) + `(cond + ((plusp ,n) ,pos) + ((minusp ,n) ,neg) + (t ,zer)))) + +;; sly already pretty-prints soooo +(defmacro mac (expr) + (let1 expanded (gensym "EXPANDED") + `(let ((,expanded (macroexpand-1 ',expr))) + ;; (pprint ,expanded) + ,expanded))) + +(defmacro in (obj &rest choices) + (once-only (obj) + `(or ,@(mapcar #'(lambda (c) `(eql ,obj ,c)) + choices)))) + +(defmacro inq (obj &rest args) + `(in ,obj ,@(mapcar #'(lambda (a) `',a) + args))) + +(defmacro in-if (fn &rest choices) + (once-only (fn) + `(or ,@ (mapcar #'(lambda (c) `(funcall ,fn ,c)) + choices)))) + +(defun >casex (g cl) + (let ((key (car cl)) (rest (cdr cl))) + (cond ((consp key) `((in ,g ,@key) ,@rest)) + ((inq key t otherwise) `(t ,@rest)) + (t (error "bad >case clause"))))) + +(defmacro >case (expr &rest clauses) + (once-only (expr) + `(cond ,@(mapcar #'(lambda (cl) (>casex expr cl)) + clauses)))) + +;; we have loop for for while and till + +(defmacro allf (val &rest args) + (once-only (val) + `(setf ,@(mapcan #'(lambda (a) `(,a ,val)) + args)))) + +(defmacro nilf (&rest args) + `(allf nil ,@args)) + +(define-modify-macro toggle1 () not) +(defmacro toggle (&rest args) + `(progn + ,@(mapcar #'(lambda (a) `(toggle1 ,a)) + args))) + +;; more from alexandria +;; concf (nconcf) +;; concnew (roughly, unionf) + +;; very cool +(defmacro _f (op place &rest args) + (multiple-value-bind (vars forms var set access) + (get-setf-expansion place) + `(let* (,@(mapcar #'list vars forms) + (,(car var) (,op ,access ,@args))) + ,set))) + +;; ANAPHORS! +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +(defmacro awhen (test &body body) + `(aif ,test + (progn ,@body))) + +(defmacro awhile (expr &body body) + `(do ((it ,expr ,expr)) + ((not it)) + ,@body)) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro acond (&rest clauses) + (if (null clauses) + nil + (once-only ((test (caar clauses))) + `(if ,test + (let ((it ,test)) ,@(cdar clauses)) + (acond ,@(cdr clauses)))))) + +(defmacro alambda (args &body body) + `(labels ((self ,args ,@body)) + #'self)) + +;; reminds me of clojure's -> (i'll add that why not) +;; (i'll probably end up integrating another alexandria-like that has it anyway :P) +;; (n)let me be fancy +(defmacro ablock (tag &rest args) + `(block ,tag + ,(nlet self ((args args)) + (case (length args) + (0 nil) + (1 (car args)) + (t `(let1 ((it ,(car args))) + ,(self (cdr args)))))))) + +;; clever! +;; is the or necessary? +(defmacro aif2 (test then &optional else) + (with-gensyms (ok) + `(multiple-value-bind (it ,ok) ,test + (if (or it ,ok) + ,then + ,else)))) + +(defmacro awhen2 (test &body body) + `(aif2 ,test + (progn ,@body))) + +(defmacro awhile2 (test &body body) + (with-gensyms (flag) + `(let ((,flag t)) + (loop while ,flag + (aif2 ,test + (progn ,@body) + (setf ,flag nil)))))) + +;; doubt i'll use it but for completeness +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (let ((cl1 (car clauses))) + (with-gensyms (val win) + `(multiple-value-bind (,val ,win) ,(car cl1) + (if (or ,val ,win) + (let ((it ,val)) ,@(cdr cl1)) + (acond2 ,@(cdr clauses)))))))) + +;; i was being foolish +;; pg's is awesome stuff +#| +(defvar *fn-builders* (make-hash-table)) +(defmacro defbuilder (name (&rest args) &body body) + `(setf (gethash ',name *fn-builders*) (alambda ,args ,@body))) + +(defbuilder lambda (args &rest body) `(lambda ,args ,@body)) +(defbuilder and (&rest fs) + (with-gensyms (args) + `(lambda (&rest ,args) + (and ,@(loop for f in fs + collecting `(apply #',(rbuild f) ,args)))))) +(defbuilder or (&rest fs) + (with-gensyms (args) + `(lambda (&rest ,args) + (or ,@(loop for f in fs + collecting `(apply #',(rbuild f) ,args)))))) +(defbuilder compose (&rest fs) + ) +|# + +(declaim (ftype (function (t) t) rbuild)) + +(defun build-compose (fns) + (with-gensyms (g) + `(lambda (,g) + ,(nlet rec ((fns fns)) + (if fns + `(,(rbuild (car fns)) + ,(rec (cdr fns))) + g))))) + +(defun build-call (op fns) + (with-gensyms (g) + `(lambda (,g) + (,op ,@(mapcar #'(lambda (f) + `(,(rbuild f) ,g)) + fns))))) + +(defun rbuild (expr) + (if (or (atom expr) (inq (car expr) lambda function)) + expr + (if (eq (car expr) 'compose) + (build-compose (cdr expr)) + (build-call (car expr) (cdr expr))))) + +(defmacro fn (expr) + "shorthand for writing functions of a single argument +(fn f) => #'f +(fn (f g)) => (lambda (x) (f (g x))) +(fn (compose a b c d)) => (lambda (x) (a (b (c (d x))))) +(fn (list f g h)) => (lambda (x) (list (f x) (g x) (h x))) +" + `#',(rbuild expr)) + +(defmacro alrec (rec &optional base) + (with-gensyms (fn) + `(lrec #'(lambda (it ,fn) + (symbol-macrolet ((rec (funcall ,fn))) + ,rec)) + ,base))) + +(defmacro on-cdrs (rec base &rest lsts) + `(funcall (alrec ,rec #'(lambda () ,base)) ,@lsts)) + +(defmacro atrec (rec &optional (base 'it)) + (with-gensyms (lfn rfn) + `(trec #'(lambda (it ,lfn ,rfn) + (declare (ignorable it)) + (symbol-macrolet ((left (funcall ,lfn)) + (right (funcall ,rfn))) + ,rec)) + #'(lambda (it) ,base)))) + +(defmacro on-trees (rec base &rest trees) + `(funcall (atrec ,rec ,base) ,@trees)) + +(defvar unforced (gensym)) + +;; a struct instead of a lambda is more visible +(defstruct promise forced closure) + +;; interesting approach +(defmacro delay (&body body) + (with-gensyms (self) + `(let ((,self (make-promise :forced unforced))) + (setf (promise-closure ,self) + #'(lambda () + (setf (promise-forced ,self) (progn ,@body)))) + ,self))) + +(defun force (x) + (if (promise-p x) + (if (eq (promise-forced x) unforced) + (funcall (promise-closure x)) + (promise-forced x)) + x)) + +(defmacro abbrev (short long) + `(defmacro ,short (&rest args) + `(,',long ,@args))) + +(defmacro abbrevs (&rest names) + `(progn + ,@(loop for pair in (group names 2) + collecting `(abbrev ,@pair)))) + +(abbrevs dbind destructuring-bind + mvbind multiple-value-bind + mvsetq multiple-value-setq) + +;; not great +(defmacro propmacro (propname) + `(defmacro ,propname (obj) + `(get ,obj ',',propname))) + +(defmacro propmacros (&rest props) + `(progn + ,@(loop for prop in props + collecting `(propmacro ,prop)))) + +;; meh +;; i bet this'll come up +(defun fix (f x0 &key (test #'eql)) + (fpromote (f test) + (nlet wow ((x (f x0)) (last x0)) + (if (test x last) + x + (wow (f x) x))))) + +(defmacro as-> (val name &body body) + (cond1 + (null body) val + (null (cdr body)) `(let ((,name ,val)) ,(car body)) + `(let* ,(mapcar #'(lambda (b) `(,name ,b)) (cons val (butlast body))) + ,(lastcar body)))) + +;; even more for fun +(defmacro a-> (val &body body) + `(as-> ,val it ,@body)) + +;; (defmacro <>-> (val &body body) +;; `(as-> ,val <> ,@body)) + +(defmacro doprod ((&rest binds) &body body) + (if (null binds) + `(progn ,@body) + `(loop for ,(first (car binds)) in ,(second (car binds)) + do (doprod ,(cdr binds) ,@body)))) + +(defpattern structure (expr) + (match expr + ((list 'quote x) `',x) + ((cons a b) `(cons (structure ,a) (structure ,b))) + (x x))) + +(defmacro begin (&body body) + "PROGN that admits internal, sequential defines written = a la arc" + (match body + ((list stmt) stmt) + ((cons stmt rest) + (match stmt + ((structure ('= ('values . binds) . body)) + `(multiple-value-match (progn ,@body) + (,binds (begin ,@rest)))) + + ((list* '= pattern body) + `(let-match1 ,pattern (progn ,@body) + (begin ,@rest))) + + ((structure ('=f name args . body)) + `(flet ((,name ,args (begin ,@body))) + (begin ,@rest))) + + (_ `(progn ,stmt (begin ,@rest))))) + (_ nil))) diff --git a/word-search.lisp b/word-search.lisp new file mode 100644 index 0000000..4814eae --- /dev/null +++ b/word-search.lisp @@ -0,0 +1,25 @@ +;; TODO: + +;; an M*N word search has M horiz, N vert, M diag, N diag + +(load "utils.lisp") + +;; not good +(defun eacharray (f arr) + (apply #'map-product + #'(lambda (&rest idxs) (apply f (apply #'aref arr idxs) idxs)) + (mapcar #'iota (array-dimensions arr)))) + +(defmacro docross ((x y &optional c) arr &body body) + (once-only (arr) + `(loop for ,y below (array-dimension ,arr 0) + do (loop for ,x below (array-dimension ,arr 1) + do + ,(if c + `(symbol-macrolet ((,c (aref ,arr ,y ,x))) + (progn ,@body)) + `(progn ,@body)))))) + + +(defun things (arr words) + (docross (x y)))