Skip to content
Browse files

Monadic parser update, bug fixes.

  • Loading branch information...
1 parent 1569cee commit 9b284ac5b159045a308912ee73ec942272e413d6 @VincentToups committed Oct 10, 2010
Showing with 883 additions and 38 deletions.
  1. +10 −1 README.md
  2. +137 −0 animator.el
  3. +162 −1 chemistry.el
  4. +37 −15 codewalking-utils.el
  5. +10 −10 defn.el
  6. +34 −0 functional.el
  7. +151 −0 monad-parse.el
  8. +103 −0 monad-parse.md
  9. +76 −1 monads.el
  10. +36 −0 units.el
  11. +125 −8 utils.el
  12. +2 −2 with-stack.el
View
11 README.md
@@ -222,4 +222,13 @@ Most useful in the utils package may be a pair of functions for creating and man
(tbl a-table :x) ; returns the value at key :x
Update 5 June 2010
-* Corrected a bug in defn expansion with recur.
+* Corrected a bug in defn expansion with recur.
+
+Update 10 Oct 2010
+* added lots of bug fixes, codewalking macros and functions to help
+write them, `capturing-defun` and `capturing-lambda` which attempt to
+meaningfully capture their apparent lexical scope (don't really work)
+* added lex-lambda and lex-defun which automatically create lexical
+scopes around their bodies containing their args.
+* implemented monadic parser combinators using the monads in monads.el
+* added lots more stack language functions.
View
137 animator.el
@@ -0,0 +1,137 @@
+(require 'utils)
+
+(setf *animator-funs* (alist>>))
+(setf *animator-color-stack* nil)
+
+
+(defmacro* with-animator (&body body)
+ `(labels ,(loop for info in *animator-funs* collect
+ (let ((actual-name (car info))
+ (local-name (car (cadr info)))
+ (arglist (cadr (cadr info)))
+ (argsym (gensym "animator-args-")))
+ `(,local-name (&rest ,argsym) (apply #',actual-name ,argsym))))
+ ,@body))
+(defmacro* defanimatorfun (name arglist docstring &body body)
+ (let ((actual-name (internf "animator-%s" name)))
+ (setf *animator-funs* (alist>> *animator-funs*
+ actual-name (list name arglist)))
+ `(defun ,actual-name ,arglist ,docstring (with-animator ,@body))))
+(defun start-animator-process ()
+ (let ((sh (shell "*animator*")))
+ (comint-send-strings sh "animator")
+ (setq *animator* sh)))
+(start-animator-process)
+
+(defanimatorfun send (&rest strings)
+ (apply #'comint-send-strings *animator* strings))
+
+(defanimatorfun flush ()
+ (comint-send-strings *animator* "flush"))
+(defanimatorfun frame ()
+ (comint-send-strings *animator* "frame"))
+
+(defanimatorfun color (cc)
+ (if (listp cc)
+ (let* ((s (format "%s" cc))
+ (n (length s)))
+ (animator-send (concat "color " (substring s 1 (- n 1)))))
+ (animator-send (format "color %s" cc))))
+
+(defanimatorfun push-color (cc)
+ (push cc *animator-color-stack*)
+ (if (listp cc)
+ (let* ((s (format "%s" cc))
+ (n (length s)))
+ (animator-send (concat "color " (substring s 1 (- n 1)))))
+ (animator-send (format "color %s" cc))))
+(defanimatorfun pop-color ()
+ (let ((clr (pop *animator-color-stack*))
+ (top (car *animator-color-stack*)))
+ (if top (animator-color top)
+ (animator-color "black"))))
+
+
+
+(defmacro* with-animator-color (color &body body)
+ (let ((color-sym (gensym "animator-color-")))
+ `(let ((,color-sym ,color))
+ (animator-push-color ,color-sym)
+ ,@body
+ (animator-pop-color))))
+
+
+(defmacro* with-flush/frame (&body body)
+ `(progn (animator-frame) ,@body (animator-flush)))
+
+(defanimatorfun dot (x y)
+ (comint-send-strings *animator*
+ (format "dot %f %f" x y)))
+
+(defanimatorfun dots (pairs)
+ (loop for pair in pairs do
+ (apply #'animator-dot pair)))
+
+(defanimatorfun line (x1 y1 x2 y2)
+ (animator-send (format "line %f %f %f %f" x1 y1 x2 y2)))
+
+(defanimatorfun disjoint-lines (&rest lines)
+ (loop for line in lines do
+ (apply animator-line line)))
+
+(defanimatorfun connected-lines (&rest args)
+ (let ((args (flatten args)))
+ (animator-send
+ (concat "lines "
+ (foldl (lambda (it ac) (concat ac (format " %f" it)))
+ ""
+ args)))))
+
+(defanimatorfun poly (&rest args)
+ (let ((args (flatten args)))
+ (animator-send
+ (concat "poly "
+ (foldl (lambda (it ac) (concat ac (format " %f" it)))
+ ""
+ args)))))
+
+(defanimatorfun circle (x y r &optional verts)
+ (let ((verts (if verts verts 25)))
+ (animator-send (format "circle %f %f %f %f" x y r verts))))
+
+(defanimatorfun filled-circle (x y r &optional verts)
+ (let ((verts (if verts verts 25)))
+ (animator-send (format "fillcircle %f %f %f %f" x y r verts))))
+
+(defanimatorfun text (x y text &optional alignment)
+ (if alignment
+ (animator-send (format "text %s %f %f \"%s\"" alignment x y text))
+ (animator-send (format "text %f %f \"%s\"" x y text))))
+
+
+
+
+(dont-do (with-flush/frame (animator-text 0 0 "HOLY SHEET!"))
+ (loop for i from 1 to 1000000 do
+ (sleep-for 0 10)
+ (with-flush/frame
+ (print (* 50.0 (sin (/ i 100.0))))
+ (animator-text 0
+ (* 50.0 (sin (/ i 100.0)))
+ "HOLY SHEEET!!!")))
+
+ (with-animator
+ (with-flush/frame (text 0 0 "SUP DAWG")))
+
+ (with-animator
+ (with-flush/frame
+ (animator-poly '(-0.5 -0.5) '(-0.5 0.5) '(0.5 0.5) '(0.5 -0.5))
+ (with-animator-color "blue"
+ (animator-poly '(-0.25 -0.25) '(-0.25 0.25) '(0.25 0.25) '(0.25 -0.25)))
+ (animator-poly '(-0.125 -0.125) '(-0.125 0.125) '(0.125 0.125) '(0.125 -0.125))))
+ (with-animator
+ (color "green"))
+ )
+
+
+(provide 'animator)
View
163 chemistry.el
@@ -1,5 +1,8 @@
(require 'with-stack)
(require 'eperiodic)
+(require 'defn)
+(require 'monads)
+(require 'functional)
(defun element-name (element)
(||| 'name {element} 2>assoc 1>cdr))
@@ -99,4 +102,162 @@
(symbolp en2))
nil))))
-(setf chemical-names (||| {eperiodic-element-properties} '(1>element-symbol) map))
+(setf chemical-names (||| {eperiodic-element-properties} '(1>element-symbol) map))
+
+(defun generate-conditions (alist)
+ (foldl (lambda (it ac)
+ (domonad monad-seq
+ [a-case ac
+ component (cadr it)]
+ (cons (list (car it) component) a-case)))
+ (domonad monad-seq
+ [q (cadr (car alist))]
+ (list (list (car (car alist)) q)))
+ (cdr alist)))
+(defun generate-conditions>> (&rest rest)
+ (generate-conditions (apply #'alist>> rest)))
+
+(defun sort-condition (condition-list key)
+ (functional-sort condition-list
+ (lambda (a b) (< (alist a key) (alist b key)))))
+
+(defun group-by-condition (condition-list key &optional randomize)
+ (mapcar #'cadr (foldl
+ (lambda (it ac)
+ (let ((val (alist it key)))
+ (alist-cons ac val it)))
+ ()
+ condition-list)))
+(defun ungroup (grouped-condition-list)
+ (flatten-once grouped-condition-list))
+
+(defun add-permutations (conditions-list condition-name values)
+ (domonad monad-seq [c conditions-list
+ v values]
+ (alist>> c condition-name v)))
+
+(defun keyword->string (kw)
+ (let ((s (format "%s" kw)))
+ (substring s 1 (length s))))
+
+(defun condition->filename (condition)
+ (||| lisp-val: (let ((keys (mapcar #'car condition)))
+ (foldl (lambda (it ac)
+ (concatf (list ac "=%s=%0.6d")
+ (keyword->string (car it))
+ (cadr it)))
+ ""
+ condition))
+ dup 1>length 1 swap 3>substring))
+
+(defun dsf-prep (str)
+ (let-repeatedly str
+ (replace-regexp-in-string (rxq ".txt") "" str)
+ (replace-regexp-in-string "^.*/" "" str)))
+
+(defun string->kw (s)
+ (read (concat ":" s)))
+
+(defun* dsf (str &optional (field nil) (sep (rxq "=")))
+ "dsf decomposes the filename in STR into an alist."
+ (let* ((parts (split-string (dsf-prep str) sep))
+ (fields (mapcar #'string->kw (even-indexed-elements parts)))
+ (vals (mapcar #'read (odd-indexed-elements parts)))
+ (alist (zip fields vals)))
+ (if field (alist alist field)
+ alist)))
+
+(defun kw->string (kw)
+ (let ((s (format "%s" kw)))
+ (substring s 1 (length s))))
+
+(defun print-condition (condition &optional handlers)
+ (join (mapcar (lambda (condition)
+ (let* ((key (car condition))
+ (handler (alist handlers key))
+ (val (if handler (funcall handler (cadr condition))
+ (cadr condition))))
+ (format "%s: %s"
+ (kw->string key)
+ val))) condition) ", "))
+
+
+(defun generate-instructions (condition handler-alist final-volume volume-units)
+ (format "for %s\n \t%s and fill to %f %sL"
+ (print-condition condition)
+ (join (mapcar
+ (lambda (condition)
+ (let* ((key (car condition))
+ (handler (alist handler-alist key)))
+ (funcall handler (cadr condition)))) condition) "\n\t")
+ (funcall (alist-in *units-map* `(,volume-units :in)) final-volume)
+ (||| {volume-units} "%s" swap 2>format dup length 1 swap substring)))
+
+(defun to-string (x) (format "%s" x))
+
+(defun dilution-volume (target-volume stock-concentration desired-concentration)
+ (/ (* target-volume desired-concentration) stock-concentration))
+
+
+
+(defun concentration-handler (substance desired-concentration stock final-volume units)
+ (let ((dv (dilution-volume final-volume stock desired-concentration)))
+ (format "Mix %f %sL of %s stock" (funcall (alist-in *units-map* `(,units :in)) dv)
+ (||| {units} "%s" swap 2>format dup length 1 swap substring) substance)))
+
+(defcurryl hpo-handler concentration-handler
+ "HPO")
+
+(defcurryl da-handler concentration-handler
+ "Dopamine")
+
+(defcurryr default-da-handler da-handler (from-milli 1) (from-milli 50) :micro)
+(defcurryr default-hpo-handler hpo-handler (from-milli 1000) (from-milli 50) :micro)
+
+(defdecorated default-hpo-handler-micro default-hpo-handler
+ (lambda (arglist)
+ (cons (from-micro (car arglist))
+ (cdr arglist))))
+
+(defdecorated default-da-handler-nano default-da-handler
+ (lambda (arglist)
+ (cons (from-nano (car arglist))
+ (cdr arglist))))
+
+(defun default-ph (x)
+ (format "pH of added buffer should be %f" (from-centi x)))
+
+(setq default-handler-alist
+ (alist>>
+ :samplePh #'default-ph
+ :sampleDa #'default-da-handler-nano
+ :sampleHpo #'default-hpo-handler-micro))
+
+(defun generate-ph-hpo-da-experiment-files (condition-args n-trials)
+ (let ((conditions (||| {condition-args} '(6>generate-conditions)
+ compose call
+ :samplePh 2>group-by-condition
+ '( 1>permute-list ) map 1>ungroup))
+ (trials (range n-trials)))
+ (let ((instructions (find-file "instructions.md"))
+ (log (find-file "log.org")))
+ (with-current-buffer log
+ (kill-region (point-min) (point-max))
+ (insertf "| n | filename | trial | bufferPh | samplePh | sampleDa | sampleHpo |\n"))
+ (with-current-buffer instructions
+ (kill-region (point-min) (point-max)))
+ (loop for c in conditions and i from 1 do
+ (loop for trial in (add-permutations (list c) :trial trials) do
+ (with-current-buffer log
+ (insertf "| | %s | %d |7.40 | %f | %f | %f |\n"
+ (condition->filename trial)
+ (alist trial :trial)
+ (alist trial :samplePh)
+ (alist trial :sampleDa)
+ (alist trial :sampleHpo))))
+ (with-current-buffer instructions
+ (insertf "%d.\t %s\n" i
+ (generate-instructions c default-handler-alist (from-milli 50) :milli)))))))
+
+
+(provide 'chemistry)
View
52 codewalking-utils.el
@@ -50,8 +50,9 @@
(if (or (eq (car form) 'progn)
(eq (car form) 'prog1))
(collect-usage-info-prog-like (cdr form) global-info local-info)
- (foldl (la (sub-form glob-inf)
- (collect-usage-info sub-form glob-inf local-info))
+ (foldl (lexical-let ((li local-info))
+ (la (sub-form glob-inf)
+ (collect-usage-info sub-form glob-inf li)))
global-info
form)))
@@ -71,16 +72,17 @@
(defun collect-usage-info-function (form global-info local-info)
(let* ((symbol-name (cadr form)))
(if (symbolp symbol-name)
- (let* ((binding-info (symbol-binding-info symbol-name local-info))
- (f-bound (cadr binding-info)))
- (let-seq (s-count f-count su-count fu-count) (symbol-bind-counts symbol-name global-info)
- (alist>> global-info symbol-name
- (list s-count
- (if f-bound (+ 1 f-count) f-count)
- su-count
- (if (not f-bound)
- (+ 1 fu-count)
- fu-count)))))
+ (progn
+ (let* ((binding-info (symbol-binding-info symbol-name local-info))
+ (f-bound (cadr binding-info)))
+ (let-seq (s-count f-count su-count fu-count) (symbol-bind-counts symbol-name global-info)
+ (alist>> global-info symbol-name
+ (list s-count
+ (if f-bound (+ 1 f-count) f-count)
+ su-count
+ (if (not f-bound)
+ (+ 1 fu-count)
+ fu-count))))))
(collect-usage-info-lambda form global-info local-info))))
@@ -169,6 +171,9 @@ LOCAL-INFO is recursively defined, but is of the form
Where bound-as-(function/symbol) are either t or nil."
(cond
+ ((numberp form) global-info)
+ ((stringp form) global-info)
+ ((vectorp form) global-info)
((symbolp form)
(cond ((eq 't form) global-info)
((eq 'nil form) global-info)
@@ -203,7 +208,7 @@ LOCAL-INFO is recursively defined, but is of the form
((setqp form)
(collect-usage-info-setq form global-info local-info))
(t ; function application
- (collect-usage-info-prog-like (cdr form)
+ (collect-usage-info-prog-like `(progn ,@(cdr form))
(collect-usage-info-function `(function ,(car form)) global-info local-info)
local-info))))))
@@ -248,7 +253,7 @@ LOCAL-INFO is recursively defined, but is of the form
(print x)
x)
-(defmacro* lexical-lambda (args &body body)
+(defmacro* capturing-lambda (args &body body)
(let* ((expanded (cadr (macroexpand-all `(lambda ,args ,@body))))
(info (collect-usage-info expanded))
(unbound-symbols (get-unbound-symbols-list info))
@@ -267,7 +272,7 @@ LOCAL-INFO is recursively defined, but is of the form
,expanded)))))
-(defmacro* lexical-defun (name args docstring &body body)
+(defmacro* capturing-defun (name args docstring &body body)
(let* ((expanded (macroexpand-all `(defun ,name ,args ,docstring ,@body)))
(info (collect-usage-info expanded))
(unbound-symbols (get-unbound-symbols-list info))
@@ -287,3 +292,20 @@ LOCAL-INFO is recursively defined, but is of the form
+
+(defun /|-argpred (x)
+ (and (symbolp x)
+ (let* ((strv (format "%s" x))
+ (first-char (substring strv 0 1))
+ (rest-chars (substring strv 1 (length strv)))
+ (rest-count (string-to-number rest-chars)))
+ (and (string= "%" first-char)
+ (> rest-count 0)))))
+
+(defmacro* /| (&body body)
+ (let* ((expanded (macroexpand-all `(progn ,@body)))
+ (usage-info (collect-usage-info expanded))
+ (args (filter #'/|-argpred (get-unbound-symbols-list usage-info))))
+ `(function (lambda ,args ,expanded))))
+
+
View
20 defn.el
@@ -69,14 +69,14 @@
; (handle-seq-binder [a b c d :or [1 2 3 4]] '(list 1 2 3 4) '())
; (handle-seq-binder [] '() '())
-(defun table-like-get (tbl-like kw)
- (cond ((hash-table-p tbl-like) (tbl tbl-like kw))
- ((listp tbl-like) (cadr (assq kw tbl-like)))))
-(defun* table-like-get-or (tbl-like kw &optional (or-val nil))
- (cond ((hash-table-p tbl-like) (tbl-or tbl-like kw or-val))
- ((listp tbl-like)
- (let ((v (assoc-default kw tbl-like #'eq nil)))
- (if v (car v) or-val)))))
+;; (defun table-like-get (tbl-like kw)
+;; (cond ((hash-table-p tbl-like) (tbl tbl-like kw))
+;; ((listp tbl-like) (cadr (assq kw tbl-like)))))
+;; (defun* table-like-get-or (tbl-like kw &optional (or-val nil))
+;; (cond ((hash-table-p tbl-like) (tbl-or tbl-like kw or-val))
+;; ((listp tbl-like)
+;; (let ((v (assoc-default kw tbl-like #'eq nil)))
+;; (if v (car v) or-val)))))
(dont-do
(table-like-get (tbl! :x 10 :y 10) :x)
@@ -557,7 +557,7 @@
(loop while ,loop-sentinal do
(setq ,return-value (progn
(setq ,loop-sentinal nil)
- ,(expand-recur `(progn ,@body) t loop-sentinal binding-parts t))))
+ ,(expand-recur `(progn ,@body) t loop-sentinal binding-parts ))))
,return-value))))
(defmacro* dloop-single-arg_ (bindings &body body)
@@ -571,7 +571,7 @@
(loop while ,loop-sentinal do
(setq ,return-value (progn
(setq ,loop-sentinal nil)
- ,(expand-recur `(progn ,@body) t loop-sentinal binding-parts t))))
+ ,(expand-recur `(progn ,@body) t loop-sentinal binding-parts ))))
,return-value))))
View
34 functional.el
@@ -0,0 +1,34 @@
+
+(defmacro defcurryl (newname oldname &rest args)
+ (let ((narglist (gensym (format "%s-arglist" newname))))
+ `(defun ,newname (&rest ,narglist)
+ (apply #',oldname ,@args ,narglist))))
+
+(defmacro defcurryr (newname oldname &rest args)
+ (let ((narglist (gensym (format "%s-arglist" newname))))
+ `(defun ,newname (&rest ,narglist)
+ (apply #',oldname (append ,narglist (list ,@args))))))
+
+(defmacro clambdal (oldf &rest args)
+ (let ((narglist (gensym "clambdal-arglist-")))
+ `(lambda (&rest ,narglist)
+ (apply #',oldf ,@args ,narglist))))
+
+(defmacro clambdar (oldf &rest args)
+ (let ((narglist (gensym "clambdal-arglist-")))
+ `(lambda (&rest ,narglist)
+ (apply #',oldf (apply ,narglist (list ,@args))))))
+
+(defmacro defdecorated (newname oldname transformer)
+ (let ((args (gensym (format "%s-decorated-args" newname))))
+ `(defun ,newname (&rest ,args)
+ (apply #',oldname
+ (funcall #',transformer ,args)))))
+
+(defmacro lambdecorate (oldf transformer)
+ (let ((args (gensym (format "decorated-args"))))
+ `(lambda (&rest ,args)
+ (apply #',oldf
+ (funcall #',transformer ,args)))))
+
+(provide 'functional)
View
151 monad-parse.el
@@ -0,0 +1,151 @@
+(require 'monads)
+(require 'utils)
+(require 'eieio)
+(require 'cl)
+
+(defn parser-bind [parser fun]
+ (fn [input]
+ (loop for (value . input) in (funcall parser input)
+ append (funcall (funcall fun value) input))))
+
+(defn parser-return [val]
+ (fn [input]
+ (list (cons val input))))
+
+(setq monad-parse
+ (tbl!
+ :m-return #'parser-return
+ :m-bind #'parser-bind))
+
+(defclass <parser-input-string> ()
+ ((data :accessor string-of :initarg :string)
+ (ix :accessor index-of :initarg :index :initform 0)))
+
+(defmethod input-empty? ((input <parser-input-string>))
+ (= (length (string-of input)) (index-of input)))
+(defmethod input-empty-p ((input <parser-input-string>))
+ (= (length (string-of input)) (index-of input)))
+
+(defmethod input-first ((input <parser-input-string>))
+ (elt (string-of input) (index-of input)))
+
+(defmethod input-rest ((input <parser-input-string>))
+ (make-instance '<parser-input-string> :string
+ (string-of input)
+ :index (+ 1 (index-of input))))
+
+(defun empty-string-parser ()
+ (make-instance '<parser-input-string>
+ :string "" :index 0))
+
+(defmethod input-as-string ((input <parser-input-string>))
+ (substring (string-of input) (index-of input) (length (string-of input))))
+
+(defun string->parser-input (str)
+ (make-instance '<parser-input-string>
+ :string str))
+
+(defun parser-fail ()
+ (lambda (input) nil))
+
+(defun parser-item ()
+ (lambda (input)
+ (unless (input-empty? input)
+ (list (cons (input-first input)
+ (input-rest input))))))
+
+(funcall (parser-item) (string->parser-input ""))
+
+(defun =satisfies (predicate)
+ (lexical-let ((lpred predicate))
+ (parser-bind (parser-item)
+ (lambda (x)
+ (if (funcall lpred x)
+ (parser-return x)
+ (parser-fail))))))
+
+(lexical-let ((digits (coerce "1234567890" 'list)))
+ (defun digit-char? (x)
+ (in x digits)))
+
+(lexical-let ((lowers (coerce "abcdefghijklmnopqrztuvwxyz" 'list))
+ (uppers (coerce "ABCDEFGHIJKLMNOPQRZTUVWXYZ" 'list)))
+ (defun upper-case-char? (x)
+ (in x uppers))
+ (defun lower-case-char? (x)
+ (in x lowers)))
+
+(defun =char (x)
+ (lexical-let ((x x))
+ (=satisfies (lambda (y) (eql x y)))))
+(defun =upper-case-char? ()
+ (=satisfies (lambda (y) (upper-case-char? y))))
+(defun =lower-case-char? ()
+ (=satisfies (lambda (y) (lower-case-char? y))))
+
+(defun =digit-char ()
+ (=satisfies #'digit-char?))
+
+(defun parser-plus (p1 p2)
+ (lexical-let ((p1 p1)
+ (p2 p2))
+ (lambda (input)
+ (append (funcall p1 input) (funcall p2 input)))))
+
+(defun letter () (parser-plus (=lower-case-char?) (=upper-case-char?)))
+
+(defun alphanumeric () (parser-plus (=digit-char) (letter)))
+
+(defun =string (input)
+ (lexical-let ((input input))
+ (if (input-empty? input)
+ (parser-return (empty-string-parser))
+ (domonad monad-parse
+ [_ (=char (input-first input))
+ _ (=string (input-rest input))] (print input)
+ input))))
+
+(lex-defun =or (parser &rest parsers)
+ (lambda (input)
+ (or (funcall parser input)
+ (when parsers
+ (funcall (apply #'=or parsers) input)))))
+
+(lex-defun =not (parser)
+ (lambda (input)
+ (let ((result (funcall parser input)))
+ (if result
+ nil
+ (list (cons t input))))))
+
+(defmacro* =let* (forms &body body)
+ `(domonad monad-parse ,forms ,@body))
+
+(lex-defun =and (p1 &rest ps)
+ (=let* [result p1]
+ (if ps
+ (apply #'=and ps)
+ result)))
+
+(defun parser-maybe (parser)
+ (=or parser (parser-return nil)))
+
+(defun letters ()
+ (=or (=let* [x (letter)
+ xs (letters)]
+ (cons x xs))
+ (parser-return nil)))
+
+(lex-defun zero-or-more (parser)
+ (=or (=let* [x parser
+ xs (zero-or-more parser)]
+ (cons x xs))
+ (parser-return nil)))
+
+
+(lex-defun one-or-more (parser)
+ (=let* [x parser
+ y (zero-or-more parser)]
+ (cons x y)))
+
+(provide 'monad-parse)
View
103 monad-parse.md
@@ -0,0 +1,103 @@
+Monadic Parser Combinators, in Emacs Lisp
+-----------------------------------------
+
+I've put together rudimentary (at the moment underdocumented) support
+for a parser monad in `monad-parse.el`. This library is something of
+a shambling mongrel. Obviously, it is in emacs lisp, but it is built
+on top of my implementation of monads and destructuring bind from
+Clojure, but it is based on [a monadic parser combinator
+library called Smug](http://common-lisp.net/~dcrampsie/smug.html) implemented by
+Drew Crampsie in Common Lisp.
+
+This was a tricky thing to get right, even with all the plumbing
+provided by the code in `monads.el` because monadic parsers depend a
+lot on lexical scope, which can be simulated in emacs lisp, but you
+have to do it explicitely.
+
+Things are basically just like Drew Crampsie's library except that
+I've used my `domonad` form to support his `=let*` form, and as a
+consequence the binding forms in that expression follow the clojure
+style, rather than the Common Lisp/Emacs Lisp style.
+
+For instance, using Smug, `zero-or-more` looks like:
+
+ (defun zero-or-more (parser)
+ (=or
+ (=let*
+ ((x parser)
+ (xs (zero-or-more parser)))
+ (result (cons x xs)))
+ (result nil)))
+
+In this library, which lacks a snappy name because it is too
+frankensteinish and slow to be really usable (probably), this would
+be:
+
+ (defun zero-or-more (parser)
+ (=or
+ (=let*
+ [x parser
+ xs (zero-or-more parser)]
+ (result (cons x xs)))
+ (result nil)))
+
+`=let*` is literally implemented as:
+
+ (defmacro* =let* (bindings &body body)
+ `(domonad monad-parse ,bindings ,@body))
+
+One important proviso is that my version of `=let*` implicitely wraps
+the `body` in a `parser-return` function. Bear this in mind when
+comparing his code and mine. I may provide a Smug compliant version
+of `=let*` eventually.
+
+One other major difference is that you've got to jump through a hoop
+to support generic input types. I've used
+[eieio](http://cedet.sourceforge.net/eieio.shtml) to provide the
+interface for a parsing input stream. Right now, only strings are
+supported as parsing streams, but I want to be able to add parsing buffers
+cheaply in the future. As a consequence, I've wrapped a string up in
+an eieio class `<parser-input-string>` with methods `input-empty?`,
+`input-empty-p` (synonyms), `input-rest`, and `input-first`. Because
+eieio does'nt cover the whole emacs class universe, you've got to wrap
+a string before using it via `string->parser-input.`
+
+Reading about [Smug](http://common-lisp.net/~dcrampsie/smug.html) is
+probably a great place to start if you want to understand this
+library, with the above provisos. Here is an example, though:
+
+ (lexical-let ((digits (coerce "1234567890" 'list)))
+ (defun digit-char? (x)
+ (in x digits)))
+
+ (lexical-let ((lowers (coerce "abcdefghijklmnopqrztuvwxyz" 'list))
+ (uppers (coerce "ABCDEFGHIJKLMNOPQRZTUVWXYZ" 'list)))
+ (defun upper-case-char? (x)
+ (in x uppers))
+ (defun lower-case-char? (x)
+ (in x lowers)))
+
+ (defun =char (x)
+ (lexical-let ((x x))
+ (=satisfies (lambda (y) (eql x y)))))
+ (defun =upper-case-char? ()
+ (=satisfies (lambda (y) (upper-case-char? y))))
+ (defun =lower-case-char? ()
+ (=satisfies (lambda (y) (lower-case-char? y))))
+
+ (defun =digit-char ()
+ (=satisfies #'digit-char?))
+
+ (defun letter () (parser-plus (=lower-case-char?) (=upper-case-char?)))
+
+ (defun alphanumeric () (parser-plus (=digit-char) (letter)))
+
+ (funcall (zero-or-more (alphanumeric)) (string->parser-input "aaaa?"))
+
+
+Have fun!
+
+Disclaimer: This library depends on so much insanity that I cannot
+guarantee that it will function as advertised or that it will not
+make you lose your mind.
+
View
77 monads.el
@@ -16,6 +16,16 @@
(if (eq (car x) 'None) (error "This should not happen, you tried to get the value of None")
(cadr x)))
+(defun Possibilities (&rest args)
+ (cons 'Possibilities args))
+
+(setf monad-possibilities
+ (tbl!
+ :m-return (lambda (x) (Possibilities x))
+ :m-bind (lambda (v f)
+ (apply #'concat (loop for possibility in (cdr v)
+ collect (cdr (f v)))))))
+
(setf monad-maybe
(tbl!
:m-return (lambda (x) (Just x))
@@ -34,24 +44,89 @@
(fn [s]
(dlet [[val new-state] (funcall mv s)]
(funcall (funcall f val) new-state))))))
+
+(setf monad-cont
+ (tbl!
+ :m-return (fn [v]
+ (fn [c]
+ (funcall c v)))
+ :m-bind
+ (fn [mv mf]
+ (fn [c]
+ (funcall mv (fn [v]
+ (funcall (mf v) c)))))))
+
+(defn fetch-state []
+ (fn [state]
+ (list state state)))
+
+(defn set-state [val]
+ (fn [state]
+ (list val val)))
+
+(defn fetch-state-alist [key]
+ (fn [state]
+ (list (alist state key) state)))
+
+(defn set-state-alist [key val]
+ (fn [state]
+ (list val (alist>> state key val))))
+
+(defmacro* defstatefun (name monad-forms &body body)
+ (let ((state (gensym "state")))
+ `(defun ,name (,state)
+ (funcall
+ (domonad monad-state ,monad-forms ,@body)
+ ,state))))
+
+
(setf monad-seq
(tbl! :m-return (lambda (x) (list x))
:m-bind (lambda (v f) (apply #'append (mapcar f v)))))
+(defun monad-set (predicate)
+ (lexical-let ((lpred predicate))
+ (tbl! :m-return (lambda (x) (list x))
+ :m-bind (lambda (v f) (unique (apply #'append (mapcar f v)) lpred)))))
+
(defn m-m-bind [monad v f]
(funcall (tbl monad :m-bind) v f))
(defn m-m-return [monad v]
(funcall (tbl monad :m-return) v))
+
(defmacro* with-monad (monad &body body)
`(labels ((m-return (x) (m-m-return ,monad x))
(m-bind (v f) (m-m-bind ,monad v f))
(>>= (v f) (m-m-bind ,monad v f)))
,@body))
+(defmacro* with-monad-dyn (monad &body body)
+ `(flet ((m-return (x) (m-m-return ,monad x))
+ (m-bind (v f) (m-m-bind ,monad v f))
+ (>>= (v f) (m-m-bind ,monad v f)))
+ ,@body))
-
+(defn halt [x]
+ (fn [c] x))
+
+(defn yield [x]
+ (fn [c]
+ (list x (fn []
+ (funcall c x)))))
+
+(defn bounce [x]
+ (fn [c]
+ (fn []
+ (funcall c x))))
+
+(defn m-chain [steps]
+ (foldl
+ (fn [step chain-expr]
+ (fn [v] (m-bind (funcall chain-expr v) step)))
+ #'m-return
+ steps))
(dont-do
(with-monad monad-seq
View
36 units.el
@@ -0,0 +1,36 @@
+(require 'with-stack)
+(setq *units-map* (alist>>))
+(flet ((drop-last (x)
+ (let* ((s (format "%s" x))
+ (n (length s)))
+ (intern (substring s 0 (- n 1))))))
+ (loop for
+ name in
+ '(base- deca- hecto- kilo- mega- giga- tera- peta- exa- zetta- yotta-) and
+ sub-name in
+ '(base- deci- centi- milli- micro- nano- pico- femto- atto- zepto- yocto-) and
+ num in
+ '(0 1 2 3 6 9 12 15 18 21 24) do
+ (eval `(defun ,(drop-last (internf "from-%s" name)) (v) (* v ,(expt 10.0 num))))
+ (eval `(defun ,(drop-last (internf "in-%s" name)) (v) (/ v ,(expt 10.0 num))))
+ (eval `(defun ,(drop-last (internf "from-%s" sub-name)) (v) (* v ,(expt 10.0 (- num)))))
+ (eval `(defun ,(drop-last (internf "in-%s" sub-name)) (v) (/ v ,(expt 10.0 (- num)))))
+
+ (eval `(univalent-stack-words ,(drop-last (internf "from-%s" name))
+ ,(drop-last (internf "in-%s" name))
+ ,(drop-last (internf "from-%s" sub-name))
+ ,(drop-last (internf "in-%s" sub-name))))
+ (setq *units-map*
+ (alist>> *units-map*
+ (read (concat ":" (format "%s" (drop-last name))))
+ (alist>> :from (eval (read (format "#'%s" (drop-last (internf "from-%s" name)))))
+ :in (eval (read (format "#'%s" (drop-last (internf "in-%s" name))))))
+ (read (concat ":" (format "%s" (drop-last sub-name))))
+ (alist>> :from (eval (read (format "#'%s" (drop-last (internf "from-%s" sub-name)))))
+ :in (eval (read (format "#'%s" (drop-last (internf "in-%s" sub-name))))))))
+ (print name)
+ (print num)))
+(provide 'units)
+
+
+
View
133 utils.el
@@ -100,12 +100,12 @@
found))))
(defun* unique (lst &optional (pred #'eq))
- (foldl
+ (reverse (foldl
(lambda (it ac)
(if (in it ac pred) ac
(cons it ac)))
'()
- lst))
+ lst)))
(defun insertf (&rest args)
(insert (apply #'format args)))
@@ -171,6 +171,13 @@
(defun list? (&rest args)
(apply #'listp args))
+(defun flatten-once (lst)
+ (foldl (lambda (it ac)
+ (if (listp it) (append ac it)
+ (suffix ac it)))
+ nil
+ lst))
+
(defun flatten (lst)
(reverse
(foldl
@@ -730,6 +737,8 @@
(dont-do
(wd))
+
+
(defun* alist (alist el)
(cadr (assoc el alist)))
(defun* alist-or (alist el &optional (or-val nil))
@@ -741,6 +750,17 @@
(let ((v (assq el alist)))
(if v v or-val)))
+(defun alist-in (root keys)
+ (foldl (lambda (it ac)
+ (alist ac it))
+ root
+ keys))
+
+(defun alist>>-in (root keys val)
+ (if (= (length keys) 1) (alist>> (car keys) val)
+ (alist>> root (car keys)
+ (alist>>-in (alist root (car keys)) (cdr keys) val))))
+
(defun alist-conjugate (alst key fun)
(let ((val (alist alst key)))
(alist>> alst key (funcall fun val))))
@@ -777,12 +797,27 @@
(symbols (mapcar #'car pairs))
(dalist (dissoc alist symbols)))
(foldl #'cons dalist (reverse (bunch-list rest)))))))
-
- ;; (if alist
- ;; (if (not (listp alist))
- ;; (apply #'alist>> (cons nil (cons alist rest)))
- ;; (foldl #'cons alist (reverse (bunch-list rest))))
- ;; alist))
+
+(defun alist-keys (alist)
+ (mapcar #'car alist))
+
+(defmacro eq-commute (fun a b)
+ `(eq (funcall ,fun ,a) (funcall ,fun ,b)))
+(defmacro bool-commute (comp fun a b)
+ `(,comp (funcall ,fun ,a) (funcall ,fun ,b)))
+
+(defun macroexpand-eval-last-sexp ()
+ (interactive)
+ (print (eval (macroexpand-all (pp-last-sexp)))))
+
+(global-set-key [\C-ce] 'macroexpand-eval-last-sexp)
+
+
+;; (if alist
+;; (if (not (listp alist))
+;; (apply #'alist>> (cons nil (cons alist rest)))
+;; (foldl #'cons alist (reverse (bunch-list rest))))
+;; alist))
;; (defun alist>> (&rest rest)
;; (let ((narg (length rest)))
@@ -824,6 +859,13 @@
(defun buffer-line ()
(buffer-substring-no-properties (get-beginning-of-line) (get-end-of-line)))
+(defun buffer-all-lines ()
+ (save-excursion (goto-char (point-min))
+ (loop collect
+ (buffer-line)
+ while (= (forward-line 1) 0))))
+
+
(defun org-line->list (str)
(mapcar #'chomp (split-string str (regexp-quote "|"))))
@@ -844,6 +886,9 @@
nil args)
(accept-process-output)
(buffer-substring (point-min) (point-max))) lb))))
+(defun* sh (command &optional (args ""))
+ "sh command args - Send a command to the shell, get back the result as a list of strings."
+ (capture-shell command args))
(defmacro la (args &rest body)
`(lambda ,args ,@body))
@@ -904,4 +949,76 @@
(interactive)
(comint-send-strings (get-buffer "*shell*") (concat "cd " (wd))))
+(defun concatf (strings &rest rest)
+ (apply #'format (apply #'concat strings) rest))
+
+(defun filter-by-index (pred list)
+ (loop for item in list and index from 0
+ when (funcall pred index) collect item))
+
+(defun odd-indexed-elements (list)
+ (filter-by-index #'oddp list))
+
+(defun even-indexed-elements (list)
+ (filter-by-index #'evenp list))
+
+(defun factor (n)
+ (mapcar #'read (cdr (split-string (car (capture-shell "factor" (format "%d" n))) " " t))))
+
+(defun table-like-get (tbl-like kw)
+ (cond ((hash-table-p tbl-like) (tbl tbl-like kw))
+ ((listp tbl-like) (cadr (assq kw tbl-like)))))
+(defun* table-like-get-or (tbl-like kw &optional (or-val nil))
+ (cond ((hash-table-p tbl-like) (tbl-or tbl-like kw or-val))
+ ((listp tbl-like)
+ (let ((v (assoc-default kw tbl-like #'eq nil)))
+ (if v (car v) or-val)))))
+
+(defun print-and-return (x)
+ (cl-prettyprint x)
+ x)
+
+(defmacro always (val)
+ (let ((s (gensym "always-"))
+ (r (gensym "rest-")))
+ `(lexical-let ((,s ,val))
+ (lambda (&rest ,r)
+ ,s))))
+
+(defun cut-region-replace (s)
+ (interactive "s")
+ (kill-region (point) (mark))
+ (insert s))
+
+
+(defmacro* lex-lambda (arglist &body body)
+ (let* ((actual-args (filter
+ (lambda (x)
+ (let ((x (format "%s" x)))
+ (and (not (string= x "&rest"))
+ (not (string= x "&optional")))))
+ arglist))
+ (lex-forms (mapcar (lambda (x) (list x x))
+ actual-args)))
+ `(lambda ,arglist
+ (lexical-let ,lex-forms ,@body))))
+
+(defmacro* lex-defun (name arglist doc &body body)
+ (let* ((actual-args (filter
+ (lambda (x)
+ (let ((x (format "%s" x)))
+ (and (not (string= x "&rest"))
+ (not (string= x "&optional")))))
+ arglist))
+ (lex-forms (mapcar (lambda (x) (list x x))
+ actual-args)))
+ (if (stringp doc)
+ `(defun ,name ,arglist ,doc
+ (lexical-let ,lex-forms ,@body))
+ `(defun ,name ,arglist
+ (lexical-let ,lex-forms ,doc ,@body)))))
+
+
+
+
(provide 'utils)
View
4 with-stack.el
@@ -471,9 +471,9 @@
-(univalent-stack-words car cdr cadr first second third fourth list regexp-quote rxq reverse)
+(univalent-stack-words car cdr cadr first second third fourth list regexp-quote rxq reverse length)
(bivalent-stack-words split-string join)
-(n-valent-stack-words 3 replace-regexp-in-string reprxstr)
+(n-valent-stack-words 3 replace-regexp-in-string reprxstr substring)
(provide 'with-stack)

0 comments on commit 9b284ac

Please sign in to comment.
Something went wrong with that request. Please try again.