├── .#monad-parse.el ├── .#monads.el ├── .#streams.el ├── .evaluation_filenames ├── partial_better-units.el ├── partial_guitar.el └── partial_macro-utils.el ├── README.md ├── README.txt ├── actionscript-utils.el ├── actionscript-utils.elc ├── advanced-utils.el ├── animator.el ├── annotate.el ├── better-monad-parse-test.el ├── better-monad-parse-test.elc ├── better-monad-parse.el ├── better-monad-parse.elc ├── better-units.el ├── binders ├── blogging.el ├── build-jane-street.el ├── chemistry.el ├── chemistry.elc ├── classy.el ├── cloudboard-bot ├── .evaluation_filenames │ └── partial_world-build.el ├── coins.el ├── coins.md ├── dice-words.el ├── draft.el └── world-build.el ├── codewalking-utils.el ├── core.esl ├── curios.html ├── curios.md ├── def.el ├── defn-readme.htm ├── defn-readme.md ├── defn.el ├── defn.elc ├── delay.md ├── el-pres.el ├── el-pres.elc ├── elab.el ├── elcie.el ├── ellision.el ├── esl-mode.el ├── esl-readme.md ├── esl.el ├── esl2.el ├── esl2.elc ├── examples ├── peg-puzzle-streams.el ├── peg-puzzle-streams.elc ├── peg-puzzle.el ├── peg-puzzle.elc ├── scratch.el └── simple-peg-puzzle.el ├── flotsam ├── esl (microcosm's conflicted copy 2009-09-12).el └── to-lambda-esl.el ├── flymake-actionscript └── build_manage.rb ├── ftbl.el ├── functional.el ├── functional.elc ├── guitar.el ├── infix.el ├── infix.elc ├── lambda-star.el ├── later.el ├── later.elc ├── latex-utils.el ├── latex-utils.elc ├── lisp-parser.el ├── lisp-parser.elc ├── loel.el ├── logging.el ├── macro-utils.el ├── macro-utils.elc ├── match.el ├── microstack.el ├── microstack.elc ├── microstack.md ├── monad-forms.el ├── monad-parse-scratch.el ├── monad-parse.el ├── monad-parse.elc ├── monad-parse.md ├── monad-stream.el ├── monad-stream.elc ├── monad-text-parse.el ├── monad-text-parse.elc ├── monad-transformers.el ├── monad-tut-examples.el ├── monad-tut-examples.elc ├── monadic-bind.png ├── monadic-types-of-interest.png ├── monads.asd ├── monads.el ├── monads.elc ├── monads.htm ├── monads.lisp ├── monads.md ├── mstack.el ├── mstack.elc ├── multi-methods.el ├── multi-methods.elc ├── multi-methods.md ├── namer.el ├── old.esl.el ├── old.loel.el ├── package.lisp ├── parse-lambda-list.el ├── parse-lambda-list.elc ├── parse-seq-binder.el ├── parse-sombers-lab-files.el ├── parse-sombers-lab-files.elc ├── parse-table-binder.el ├── parser-pres ├── index.el ├── index.elc ├── just-elisp.el ├── page-1.el ├── page-10.el ├── page-11.el ├── page-12.el ├── page-13.el ├── page-14.el ├── page-15.el ├── page-2.el ├── page-2.elc ├── page-3.el ├── page-4.el ├── page-5.el ├── page-6.el ├── page-7.el ├── page-8.el ├── page-8.elc ├── page-9.el └── scratch.el ├── partial-symbol-levenstein.el ├── pattern-macro.el ├── pattern-matching.el ├── persistent-hash-tables.el ├── persistent-hash-tables.elc ├── prolapse.el ├── prolapse.elc ├── quantities.el ├── ra-lists.el ├── ra-lists.elc ├── recur.el ├── recur.elc ├── recur.md ├── scratch.el ├── scratch.md ├── scripting.el ├── scripting.elc ├── sets.el ├── shadchen.el ├── shadchen.elc ├── simplified-lambda-list-parser.el ├── simplified-lambda-list-parser.elc ├── skip-lists.el ├── sqlite.el ├── srfi-101.sls.txt ├── stack-monads.el ├── stack-words.el ├── stack-words.elc ├── stream-scratch.el ├── streams.el ├── streams.elc ├── streams.htm ├── streams.md ├── testbuffer.txt ├── thunk.el ├── track-life.el ├── tree-monads.el ├── trie.el ├── units.el ├── units.elc ├── utils.el ├── utils.elc ├── virtues.el ├── vorg.el ├── vorg.elc ├── weighted-graph-monad.el ├── weighted-graph-monad.elc ├── weighted-graph-monad.md ├── with-stack.el ├── with-stack.elc └── with-stack.md /.#monad-parse.el: -------------------------------------------------------------------------------- 1 | toups@deluge.2185:1318248272 -------------------------------------------------------------------------------- /.#monads.el: -------------------------------------------------------------------------------- 1 | toups@deluge.1712:1302394636 -------------------------------------------------------------------------------- /.#streams.el: -------------------------------------------------------------------------------- 1 | toups@deluge.1712:1302394636 -------------------------------------------------------------------------------- /.evaluation_filenames/partial_better-units.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'recur) 3 | 4 | (defstruct unit-atom name type conversions) 5 | (defstruct unit-comp num den) 6 | 7 | (defun u*2 (u1 u2) 8 | (make-unit-comp 9 | :num 10 | (cond 11 | ((and (unit-atom? u1) 12 | (unit-atom? u2)) 13 | (list u1 u2)) 14 | ((and (unit-atom? u1) 15 | (unit-comp? u2)) 16 | (cons u1 (unit-comp-num u2))) 17 | ((and (unit-comp? u1) 18 | (unit-atom? u2)) 19 | (suffix (unit-comp-num u1) u2)) 20 | ((and (unit-comp? u1) 21 | (unit-comp? u2)) 22 | (append (unit-comp-num u1) 23 | (unit-comp-num u2)))) 24 | :den 25 | (cond 26 | ((and (unit-atom? u1) 27 | (unit-atom? u2)) 28 | (list u1 u2)) 29 | ((and (unit-atom? u1) 30 | (unit-comp? u2)) 31 | (cons u1 (unit-comp-den u2))) 32 | ((and (unit-comp? u1) 33 | (unit-atom? u2)) 34 | (suffix (unit-comp-den u1) u2)) 35 | ((and (unit-comp? u1) 36 | (unit-comp? u2)) 37 | (append (unit-comp-den u1) 38 | (unit-comp-den u2)))))) 39 | 40 | 41 | (defun u* (&rest us) 42 | (reduce #'u*2 us)) 43 | 44 | (defun u-invert (u) 45 | (if (unit-atom? u) 46 | (make-unit-comp 47 | :num '() 48 | :den (list u)) 49 | (make-unit-comp 50 | :num (unit-comp-den u) 51 | :den (unit-comp-num u)))) 52 | 53 | (defun u/ (u1 &rest us) 54 | (apply #'u* u1 (mapcar #'u-invert us))) 55 | 56 | -------------------------------------------------------------------------------- /.evaluation_filenames/partial_guitar.el: -------------------------------------------------------------------------------- 1 | (defun take-randomly (lst) 2 | (let ((ind (floor (random (length lst))))) 3 | (dloop [index 0 4 | [item & rest] lst 5 | front nil] 6 | (if (= index ind) (list item (append (reverse front) rest)) 7 | (recur (+ 1 index) rest (cons item front)))))) 8 | 9 | (take-randomly '(1 2 3 4 5 6)) 10 | 11 | (defun generate-plucking-pattern () 12 | (dloop [in-strings '(E A D G B e) 13 | out-strings nil] 14 | (if in-strings 15 | (dlet [[item rest] (take-randomly in-strings)] 16 | (recur rest (cons item out-strings))) 17 | out-strings))) 18 | 19 | (generate-plucking-pattern) 20 | 21 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | This is the stub README.txt for the nil project. 2 | -------------------------------------------------------------------------------- /actionscript-utils.el: -------------------------------------------------------------------------------- 1 | (defun jump-to-as-error () 2 | (interactive) 3 | (let ((line (buffer-subline-no-properties))) 4 | (let-seq (filename line-no-str nothing col-no-str) 5 | (filter (not-f #'empty?) (split-string line "[():\t ]")) 6 | (let ((buf (find-file filename))) 7 | (with-current-buffer buf 8 | (goto-char (point-min)) 9 | (forward-line (- (string-to-number line-no-str) 1)) 10 | (forward-char (- (string-to-number col-no-str) 1))))))) 11 | 12 | (provide 'actionscript-utils) 13 | 14 | 15 | -------------------------------------------------------------------------------- /actionscript-utils.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:44 2011 3 | ;;; from file /home/toups/elisp/utils/actionscript-utils.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (defalias 'jump-to-as-error #[nil "\306 \307\310\311!\312\313\"\"\211\314\234 \315\234 \316\234 \317\234\320 !rq\210eb\210\321\f!Sy\210\321\n!Su.\207" [line #1=#:list-55930 col-no-str nothing line-no-str filename buffer-subline-no-properties filter not-f empty\? split-string "[(): ]" 0 1 2 3 find-file string-to-number buf] 6 nil nil]) 17 | (provide 'actionscript-utils) 18 | -------------------------------------------------------------------------------- /advanced-utils.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'with-stack) 3 | (require 'defn) 4 | (require 'recur) 5 | 6 | 7 | (defun file-location (filestr) 8 | (||| {filestr} "/" rxq split-string reverse cdr reverse "/" join "/" 2>concat)) 9 | 10 | (defun file-name (filestr) 11 | (||| {filestr} "/" rxq split-string reverse car)) 12 | 13 | (defun file-extension (filestr) 14 | (||| {filestr} 1>file-name "." rxq split-string reverse car)) 15 | 16 | (dont-do 17 | (file-location "/this/is/a/test/press") 18 | (file-name "/this/is/a/test/press") 19 | (file-extension "/this/is/a/test/press.txt") 20 | ) 21 | 22 | (nthcdr 3 '(a b c d)) 23 | 24 | (recur-defun* bunch-by (n input &optional (output nil)) 25 | (if input 26 | (let ((bunch (elts input (range n))) 27 | (rest (nthcdr n input))) 28 | (recur n rest (cons bunch output))) 29 | (reverse output))) 30 | 31 | 32 | (provide 'advanced-utils) -------------------------------------------------------------------------------- /animator.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | 3 | (setf *animator-color-stack* nil) 4 | 5 | (defun start-animator-process () 6 | (let ((sh (shell "*animator*"))) 7 | (comint-send-strings sh "animator") 8 | (setq *animator* sh))) 9 | (start-animator-process) 10 | 11 | (defun animator-send (&rest strings) 12 | (apply #'comint-send-strings *animator* strings)) 13 | 14 | (defun animator-flush () 15 | (comint-send-strings *animator* "flush")) 16 | (defun animator-frame () 17 | (comint-send-strings *animator* "frame")) 18 | 19 | (defun animator-color (cc) 20 | (if (listp cc) 21 | (let* ((s (format "%s" cc)) 22 | (n (length s))) 23 | (animator-send (concat "color " (substring s 1 (- n 1))))) 24 | (animator-send (format "color %s" cc)))) 25 | 26 | (defun animator-push-color (cc) 27 | (push cc *animator-color-stack*) 28 | (if (listp cc) 29 | (let* ((s (format "%s" cc)) 30 | (n (length s))) 31 | (animator-send (concat "color " (substring s 1 (- n 1))))) 32 | (animator-send (format "color %s" cc)))) 33 | (defun animator-pop-color () 34 | (let ((clr (pop *animator-color-stack*)) 35 | (top (car *animator-color-stack*))) 36 | (if top (animator-color top) 37 | (animator-color "black")))) 38 | 39 | 40 | 41 | (defmacro* with-animator-color (color &body body) 42 | (let ((color-sym (gensym "animator-color-"))) 43 | `(let ((,color-sym ,color)) 44 | (animator-push-color ,color-sym) 45 | ,@body 46 | (animator-pop-color)))) 47 | 48 | 49 | (defmacro* with-flush/frame (&body body) 50 | `(progn (animator-frame) ,@body (animator-flush))) 51 | 52 | (defun animator-dot (x y) 53 | (comint-send-strings *animator* 54 | (format "dot %f %f" x y))) 55 | 56 | (defun animator-dots (pairs) 57 | (loop for pair in pairs do 58 | (apply #'animator-dot pair))) 59 | 60 | (defun animator-line (x1 y1 x2 y2) 61 | (animator-send (format "line %f %f %f %f" x1 y1 x2 y2))) 62 | 63 | (defun animator-disjoint-lines (&rest lines) 64 | (loop for line in lines do 65 | (apply animator-line line))) 66 | 67 | (defun animator-connected-lines (&rest args) 68 | (let ((args (flatten args))) 69 | (animator-send 70 | (concat "lines " 71 | (foldl (lambda (it ac) (concat ac (format " %f" it))) 72 | "" 73 | args))))) 74 | 75 | (defun animator-poly (&rest args) 76 | (let ((args (flatten args))) 77 | (animator-send 78 | (concat "poly " 79 | (foldl (lambda (it ac) (concat ac (format " %f" it))) 80 | "" 81 | args))))) 82 | 83 | (defun animator-circle (x y r &optional verts) 84 | (let ((verts (if verts verts 25))) 85 | (animator-send (format "circle %f %f %f %f" x y r verts)))) 86 | 87 | (defun animator-filled-circle (x y r &optional verts) 88 | (let ((verts (if verts verts 25))) 89 | (animator-send (format "fillcircle %f %f %f %f" x y r verts)))) 90 | 91 | (defun animator-text (x y text &optional alignment) 92 | (if alignment 93 | (animator-send (format "text %s %f %f \"%s\"" alignment x y text)) 94 | (animator-send (format "text %f %f \"%s\"" x y text)))) 95 | 96 | (defun animator-dup () 97 | (animator-send "push")) 98 | 99 | (defun animator-pop () 100 | (animator-send "pop")) 101 | 102 | (defun animator-ident () 103 | (animator-send "ident")) 104 | 105 | (defun animator-shift (x y) 106 | (animator-send (format "shift %f %f" x y))) 107 | 108 | (defun animator-rotate (degrees) 109 | (animator-send (format "rotate %f" degrees))) 110 | 111 | (defun animator-scale (x &optional y) 112 | (let ((y (if y y x))) 113 | (animator-send (format "scale %f %f" x y)))) 114 | 115 | (defun animator-viewport (left bottom w h) 116 | (animator-send (format "viewport %f %f %f %f" left bottom w h))) 117 | 118 | (defun create-animator-format-string (name-string args) 119 | (loop for i from 1 to (length args) do 120 | (setq name-string (concat name-string " %f"))) 121 | name-string) 122 | 123 | (defmacro* def-numeric-animator-primitive (name &optional doc &rest arg-names) 124 | (let ((interface-name (internf "animator-%s" name)) 125 | (name-string (format "%s" name)) 126 | (doc (if (stringp doc) doc nil)) 127 | (arg-names (if (stringp doc) arg-names 128 | (cons doc arg-names)))) 129 | `(defun ,interface-name ,arg-names ,doc 130 | (animator-send (format ,(create-animator-format-string name-string arg-names) 131 | ,@arg-names))))) 132 | 133 | (defmacro* def-numeric-animator-primitive-alt-name (interface-name name &optional doc &rest arg-names) 134 | (let ((name-string (format "%s" name)) 135 | (doc (if (stringp doc) doc nil)) 136 | (arg-names (if (stringp doc) arg-names 137 | (cons doc arg-names)))) 138 | `(defun ,interface-name ,arg-names ,doc 139 | (animator-send (format ,(create-animator-format-string name-string arg-names) 140 | ,@arg-names))))) 141 | 142 | 143 | (def-numeric-animator-primitive thick "Set animator line thickness" 144 | thickness) 145 | 146 | (def-numeric-animator-primitive alpha "Set animator transparency." alpha) 147 | 148 | (def-numeric-animator-primitive arrow "Draw an arrow pointing towards X2 Y2" 149 | x1 y1 x2 x2) 150 | 151 | (def-numeric-animator-primitive-alt-name fill-rect fillrect "Fill an animator rectangle with the current color." x y w h) 152 | 153 | (def-numeric-animator-primitive rect "Fill an animator rectangle with the current color." x y w h) 154 | 155 | 156 | 157 | 158 | 159 | 160 | (dont-do 161 | (require 'animator) 162 | (with-flush/frame (animator-text 0 0 "HOLY SHEET!")) 163 | (loop for i from 1 to 1000000 do 164 | (sleep-for 0 10) 165 | (with-flush/frame 166 | (print (* 50.0 (sin (/ i 100.0)))) 167 | (animator-text 0 168 | (* 50.0 (sin (/ i 100.0))) 169 | "HOLY SHEEET!!!"))) 170 | (with-flush/frame (animator-rect 0 0 .25 .25)) 171 | 172 | ) 173 | 174 | (provide 'animator) -------------------------------------------------------------------------------- /annotate.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'cl) 3 | (require 'functional) 4 | (require 'scripting) 5 | 6 | (defvar *annotation-directory* 7 | "~/.emacs.d/annotations/") 8 | 9 | 10 | 11 | (defun set-annotation-directory (dir) 12 | (setq *annotation-directory* dir) 13 | (unless (directoryp dir) 14 | (unless (file-exists-p dir) 15 | (make-directory dir)))) 16 | 17 | (defun gen-note-file-data (link-text) 18 | (let* ((hash (md5 link-text)) 19 | (rpieces (reverse (mapcar (par #'coerce 'string) (bunch-list (coerce hash 'list))))) 20 | (leaf (car rpieces)) 21 | (stem (join (reverse (cdr rpieces)) "/"))) 22 | (list leaf (dircat *annotation-directory* stem)))) 23 | 24 | (defun note-file-data->name (data) 25 | (concat (dircat (cadr data) (car data)) ".md")) 26 | 27 | (note-file-data->name (gen-note-file-data "test")) -------------------------------------------------------------------------------- /better-units.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'recur) 3 | 4 | (defstruct unit-atom name type abbreviation conversions) 5 | (defstruct unit-comp num den) 6 | 7 | (defalias 'unit-atom? #'unit-atom-p) 8 | (defalias 'unit-comp? #'unit-comp-p) 9 | 10 | (defun u*2 (u1 u2) 11 | (make-unit-comp 12 | :num 13 | (cond 14 | ((and (unit-atom? u1) 15 | (unit-atom? u2)) 16 | (list u1 u2)) 17 | ((and (unit-atom? u1) 18 | (unit-comp? u2)) 19 | (cons u1 (unit-comp-num u2))) 20 | ((and (unit-comp? u1) 21 | (unit-atom? u2)) 22 | (suffix (unit-comp-num u1) u2)) 23 | ((and (unit-comp? u1) 24 | (unit-comp? u2)) 25 | (append (unit-comp-num u1) 26 | (unit-comp-num u2)))) 27 | :den 28 | (cond 29 | ((and (unit-atom? u1) 30 | (unit-atom? u2)) 31 | (list u1 u2)) 32 | ((and (unit-atom? u1) 33 | (unit-comp? u2)) 34 | (cons u1 (unit-comp-den u2))) 35 | ((and (unit-comp? u1) 36 | (unit-atom? u2)) 37 | (suffix (unit-comp-den u1) u2)) 38 | ((and (unit-comp? u1) 39 | (unit-comp? u2)) 40 | (append (unit-comp-den u1) 41 | (unit-comp-den u2)))))) 42 | 43 | 44 | (defun u* (&rest us) 45 | (reduce #'u*2 us)) 46 | 47 | (defun u-invert (u) 48 | (if (unit-atom? u) 49 | (make-unit-comp 50 | :num '() 51 | :den (list u)) 52 | (make-unit-comp 53 | :num (unit-comp-den u) 54 | :den (unit-comp-num u)))) 55 | 56 | (defun u/ (u1 &rest us) 57 | (apply #'u* u1 (mapcar #'u-invert us))) 58 | 59 | (u* (make-unit-atom :name 'grams :type 'mass :conversions '()) 60 | (make-unit-atom :name 'seconds :type 'time :conversions '())) 61 | 62 | -------------------------------------------------------------------------------- /binders: -------------------------------------------------------------------------------- 1 | defn.el:(defun forms->binders (fs) 2 | defn.el:(defun forms->expressions (fs) 3 | utils.el:(defmacro let-repeatedly (name &rest forms-to-apply) 4 | utils.el: forms-to-apply) 5 | -------------------------------------------------------------------------------- /blogging.el: -------------------------------------------------------------------------------- 1 | (defun literate-scheme->markdown (input-buffer output-buffer) 2 | (labels ((insertf* (&rest args) 3 | (with-current-buffer 4 | output-buffer (insert (apply #'format args)))) 5 | (text? (line) 6 | (string= (substring line 0 (min 3 (length line))) ";;;"))) 7 | (let ((lines (with-current-buffer 8 | input-buffer 9 | (buffer-all-lines)))) 10 | (loop for line in lines do 11 | (if (text? line) 12 | (insertf* "%s\n" (chomp (substring line 3))) 13 | (insertf* " %s\n" line)))))) 14 | 15 | (literate-scheme->markdown 16 | (get-buffer "interpreter-01.rkt") 17 | (get-buffer "interpreter-01.md")) -------------------------------------------------------------------------------- /build-jane-street.el: -------------------------------------------------------------------------------- 1 | (require 'scripting) 2 | 3 | (with-working-directory "~/jane-st/" 4 | (loop for f in (sh "ls *") do 5 | (copy-file (concat "~/elisp/utils/" f) 6 | f t))) -------------------------------------------------------------------------------- /classy.el: -------------------------------------------------------------------------------- 1 | (provide 'classy) 2 | (require 'multi-methods) 3 | (require 'cl) 4 | (require 'utils) 5 | 6 | (defvar *classy-weak-table* (make-hash-table :test 'eq :weakness t) "Classy table to distinguish between lists and instances.") 7 | 8 | (defun classy-alist>> (&rest args) 9 | (let ((o (apply #'alist>> args))) 10 | (alist! o :--classy-tag (gensym "classy-tag-")) 11 | (alist! o :--class :thing) 12 | (setf (gethash (alist o :--classy-tag) *classy-weak-table*) t) 13 | o)) 14 | 15 | (let ((cc (classy-alist>> :x 10 :y 11))) 16 | (gethash (alist cc :--classy-tag) *classy-weak-table*) 17 | (alist cc :--classy-tag)) 18 | 19 | (defun classy-objectp (object) 20 | (and (listp object) 21 | (gethash (alist object :--classy-tag) *classy-weak-table*))) 22 | 23 | (defun classy-dispatch-single (object) 24 | (cond ((listp object) 25 | (cond 26 | ((classy-objectp object) (alist object :--class)) 27 | (t :list))) 28 | ((numberp object) :number) 29 | ((bufferp object) :buffer) 30 | ((vectorp object) :vector) 31 | ((stringp object) :string) 32 | ((hash-table-p object) :hash-table) 33 | ((functionp object) :function) 34 | ((keywordp object) :keyword) 35 | ((symbolp object) :symbol) 36 | (t (error "Can't find a classy type for %S" object)))) 37 | 38 | (defun classy-dispatch (&rest args) 39 | (map 'vector #'classy-dispatch-single args)) 40 | 41 | ; hierarchy 42 | 43 | ($ [:number :buffer :function :keyword :symbol :collection :classy-class] derive-from :thing) 44 | ($ [:list :vector :hash-table] derive-from :collection) 45 | 46 | (defvar *classy-classes* (make-hash-table :test 'eq)) 47 | 48 | (defun make-classy-class (&rest class-name parents field-thunk-pairs) 49 | (let ((class (classy-alist>> 50 | (loop for p in (coerce parents 'list) do 51 | ($ class-name derives-from p)) 52 | ( 53 | 54 | -------------------------------------------------------------------------------- /cloudboard-bot/.evaluation_filenames/partial_world-build.el: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | (require 'with-stack) 6 | (require 'stack-words) 7 | 8 | -------------------------------------------------------------------------------- /cloudboard-bot/coins.el: -------------------------------------------------------------------------------- 1 | (require 'with-stack) 2 | (require 'stack-words) 3 | 4 | 5 | (word: flip 1.0 1>random* .5 < '(:heads) '(:tails) if) 6 | (word: -toss ;( n - results ) 7 | nil { flip swons { 1 - dup 0 = not } dip swap } loop ) 8 | (word: heads-count ;( flips - count ) 9 | { :heads eq } filter length 'heads 2>list ) 10 | 11 | (word: tails-count ;( flips - count ) 12 | { :tails eq } filter length 'tails 2>list ) 13 | 14 | (word: toss ; ( n - toss-result ) 15 | -toss dup { heads-count } { tails-count } bi 2>list swap 2>list 1>flatten-once ) 16 | 17 | (word: botch-at? ; ( toss-result n - t/false ) 18 | 1 + { cdr cdr } dip elt :tails eq { :BOTCH } { :PASS } if ) 19 | 20 | (word: +botch-at? ; ( toss-result n - t/false ) 21 | { dup } dip 22 | 1 + { cdr cdr } dip elt :tails eq { :BOTCH } { :PASS } if ) -------------------------------------------------------------------------------- /cloudboard-bot/coins.md: -------------------------------------------------------------------------------- 1 | COINS 2 | ===== 3 | Concise Online INteraction System 4 | --------------------------------- 5 | 6 | Coins is a gameplay system based on coin tosses. All game outcomes 7 | depend on tossing coins. Here is an example: 8 | 9 | Stephen's character, KrumpKlownX7, wants to hack his way into a 10 | government database. This is a 4h task, which means Stephen needs to 11 | toss 4 heads to succeed. KrumpKlownX7 is an experienced hacker (heck, 12 | he is probably 75% cybernetic) and so has over his carreer accumated 8 13 | coins for his hacking skill. He throws his coins and gets: 14 | 15 | heads 16 | tails 17 | heads 18 | headsx 19 | tails 20 | tails 21 | heads 22 | heads 23 | 24 | Five heads and three tails. He succeeds in hacking into the system! 25 | 26 | All skill and ability based outcomes are mediated in this way. 27 | 28 | Attack/Defense 29 | -------------- 30 | 31 | Weapons and armor modify the outcome, but not the success/failure 32 | rates of attacks and defense rolls (unless specifically indicated 33 | otherwise on a particular armor or weapon). Coins are distributed 34 | onto specific weapon abilities rather than an "attack" stat. Suppose 35 | Wolverine, Marlin's character, wants to attack a watermelon with his 36 | claws. He has 12 claw attack coins, and the GM determines he is 37 | within range to attack the melon. He throws his coins: 38 | 39 | tails 40 | heads 41 | heads 42 | heads 43 | heads 44 | heads 45 | tails 46 | heads 47 | heads 48 | heads 49 | tails 50 | heads 51 | 52 | So he rolls 9 heads, and his claws are made of Adimantium, so he gets 53 | a +1 attack, giving a damage of 10. The watermelon has only 3 hit 54 | points, and so it is defeated. 55 | 56 | Suppose instead that the watermelon was wearing steel armor, and the 57 | watermelon had devoted 4 coins to heavy armor. If the watermelon 58 | chose to defend, he might roll: 59 | 60 | tails 61 | tails 62 | heads 63 | heads 64 | 65 | Two heads. He succeeds in blocking 2 points of damage. Steal armor 66 | has a plus one permanent defense point which is activated if the 67 | watermelon chooses to defend and rolls ANY heads at all, so in this 68 | scenario, three of Wolverine's damage points would be blocked. Alas, 69 | this is insufficient to block enough damage to prevent death. The 70 | watermelon is still defeated. 71 | 72 | Character Creation 73 | ------------------ 74 | 75 | Characters start out with 10 coins to distribute into any skills they 76 | wish. They should cooperate with the GM in determining which skills 77 | are appropriate for a given campaign setting. Skills should be 78 | reasonably generalizable. A character who is an expert computer 79 | hacker might be able to use some of his computer hacking coins to 80 | solve an electronics problem, for instance. Or an expert 81 | shortswordsman might wield a kendo pole or stave with diminished, but 82 | still skillful, expertise. The system is there to be worked with, not 83 | against. 84 | 85 | Hit points represent the total vitality of the character. A coin can 86 | be converted into 3 hit points instead of being used for a skill, 87 | although no more than three coins can be used this way, and hit points 88 | should not exceed twenty without specific exceptions being made. 89 | 90 | The GM and a player may decide that some skills require a "pool," like 91 | magic points. Under these circumstances, coins can be contributed to 92 | that pool in the same manner as hit points. 93 | 94 | Leveling 95 | -------- 96 | 97 | At appropriate times, the GM can award coins to the players. These 98 | can be specific to certain skills or "general coins" which can be used 99 | to extend or learn new skills or increase hit points. 100 | 101 | "Hail Mary" Skill Tests 102 | ----------------------- 103 | 104 | Players may attempt, at the discretion of the GM, to perform a feat 105 | which they do not have coins for, or for which they do not have enough 106 | coins. In these cases, they may throw the number of coins they do 107 | have, and then they must throw coins equal to the number of remaining 108 | points they need to succeed plus one, acheiving heads for all. 109 | Success represents a miraculous or lucky outcome. 110 | 111 | For example, Stephen's character, "Da NyteTyme" encounters a cyber 112 | samurai assassin sent by his enemies to thwart his latest bank heist. 113 | Luckily, Da NyteTyme has seen the samurai coming from a rooftop 114 | vantage point. His partner, a sniper, is injured, and cannot shoot, 115 | but Da NyteTyme decides to attempt an assassination shot. The GM 116 | determines that the shot has a difficulty of 4 coins. Da NyteTyme has 117 | no sniper coins, but can manage an assault weapon with 4 coins. The 118 | GM decides he can use one coin in his attempt. Da NyteTyme rolls 119 | `heads` for this toss. Now he must make 4 additional coin throws, all 120 | heads. The first toss lowered the difficulty by one, and he now needs 121 | 3+1 more heads to succeed. 122 | 123 | Da NyteTyme rolls 4 heads, and miraculously blows the head off the 124 | samurai, in a rain of blood and metal. 125 | 126 | However, if the first beyond-skill toss is tails, you fail in some 127 | spectacular way determined by the GM. 128 | 129 | Luck 130 | ---- 131 | 132 | Characters have a luck pool which is initially empty. When they 133 | receive an upgrade/experience coin, they may choose NOT to use it, and 134 | to add it to the luck pool. A coin from the luck pool can be used 135 | ONCE to force a coin flip to heads. Luck coins may be awarded by the 136 | GM for dramatic and/or quest related purposes. 137 | 138 | Conclusion 139 | ---------- 140 | 141 | That is it. Play flexible/fair! 142 | -------------------------------------------------------------------------------- /cloudboard-bot/dice-words.el: -------------------------------------------------------------------------------- 1 | (require 'with-stack) 2 | (require 'stack-words) 3 | (require 'cl) 4 | 5 | (||| 6 | word: dice ;( n-dice sides -- dice-object ) 7 | 2>list 'dice: swap 2>cons '(sided dice) 2>append end:) 8 | 9 | (||| 10 | word: coin{s} 2 dice end: 11 | word: d2 2 dice end: 12 | word: d3 3 dice end: 13 | word: d4 4 dice end: 14 | word: d5 5 dice end: 15 | word: d6 6 dice end: 16 | word: d7 7 dice end: 17 | word: d8 8 dice end: 18 | word: d9 9 dice end: 19 | word: d10 10 dice end: 20 | word: d12 12 dice end: 21 | word: d20 20 dice end: 22 | word: d40 40 dice end: 23 | word: d50 50 dice end: 24 | word: d100 100 dice end:) 25 | 26 | 27 | 28 | (univalent-stack-words listp stringp numberp not empty? error) 29 | 30 | 31 | 32 | (||| 33 | word: dice? ;( dice-object? -- boolean ) 34 | dup listp '(car 'dice: eq) '(nil) if end:) 35 | 36 | (||| 37 | word: suffix 2>suffix end: 38 | word: dice-n&sides ;( dice-object -- n sides) 39 | '(1 2) 2>elts '(car) '(cadr) bi end: 40 | word: dice-sides&n ;( dice-object -- sides n) 41 | dice-n&sides swap end:) 42 | 43 | (||| 44 | word: roll-die ;( n-sides -- roll ) 45 | 1>random* 1 + end: 46 | word: decr-dice-count ; ( sides n acc -- sides n-1 acc ) 47 | '(1 -) dip end: 48 | word: get-dice-roll ; ( sides n acc -- sides n-1 acc roll ) 49 | '(dup roll-die) 2dip rot end: 50 | word: rolling-done? ; ( sides n acc -- sides n acc bool) 51 | '(dup 0 = not) dip swap end: 52 | 53 | word: roll-dice-unsafe dice-sides&n 0 54 | '( decr-dice-count 55 | get-dice-roll 56 | + 57 | rolling-done? ) loop 58 | '(drop drop) dip 59 | end: 60 | word: roll-dice-verbose ;( dice -- roll-summary ) 61 | dice-sides&n nil 62 | '( decr-dice-count 63 | get-dice-roll 64 | swap cons 65 | rolling-done? ) loop 66 | '(drop drop) dip 67 | dup '(+) reduce :sum 68 | swap 2>list append 69 | end: 70 | ) 71 | 72 | 73 | 74 | 75 | (||| 76 | word: roll-dice ;( dice -- roll ) 77 | dup dice? '(roll-dice-unsafe) '("Tried to roll a non dice object" error) 78 | if end: 79 | word: rl ;( dice -- roll ) 80 | roll-dice end: 81 | word: roll-dice-collection ;( dice-collection -- roll ) 82 | 0 83 | '( '(tail&head) dip swap print-stack 84 | roll-dice + print-stack 85 | '(dup empty? not) dip swap ) loop 86 | '(drop) dip 87 | end: 88 | word: rlc ;( dice-collection -- roll ) 89 | roll-dice-collection 90 | end:) 91 | (|||p 2 d6 roll-dice) 92 | 93 | (|||p {{ 1 d6 2 d3 }} roll-dice-collection) 94 | (||| {{ 1 1 3 + }} ) 95 | 96 | (||| lex-let x 10 :> 3 x + ) 97 | '(3 x +) 98 | '(3 99 | 100 | 101 | (|||p 102 | 10 1 50 rolling-done?) 103 | 104 | 105 | -------------------------------------------------------------------------------- /core.esl: -------------------------------------------------------------------------------- 1 | : dip ;; ( &qt-arg x qtn -- qtn-val x ) 2 | swap retain> call hard-compile call-emacs-push end-word: 10 | : prefix 11 | swap cons end-word: 12 | 13 | : length 1 'length call-emacs-push end-word: 14 | : 1list 1 'list call-emacs-push end-word: 15 | : '() ( cons dup length retain> retain-dup 34 | 'defun 59 | end-word: 60 | 61 | : zero? ;; ( n -- b ) 62 | 0 = 63 | end-word: 64 | 65 | : neg? ;; ( n -- b ) 66 | 0 < 67 | end-word: 68 | 69 | : bi ;; ( x qt qt -- ... ) 70 | ( keep ) dip call 71 | end-word: 72 | 73 | : bi* ;; ( x y p q -- a b ) 74 | ( dip ) dip call end-word: 75 | 76 | : bi@ ;; ( x y q -- a b) 77 | dup bi* 78 | end-word: 79 | 80 | : >=0? ( pos? ) ( zero? ) bi or end-word: 81 | 82 | : car ;; ( lst -- head ) 83 | 1 'car call-emacs-push end-word: 84 | 85 | : cdr ;; ( lst -- tail ) 86 | 1 'cdr call-emacs-push end-word: 87 | 88 | : head/tail ;; ( lst -- head tail ) 89 | ( car ) ( cdr ) bi end-word: 90 | 91 | : tail/head ;; ( lst -- head tail ) 92 | ( cdr ) ( car ) bi end-word: 93 | 94 | 95 | : list>stack ;; ( lst -- eN eN-1& ) 96 | ( head/tail dup ) loop drop end-word: 97 | 98 | : reverse ;; ( lst -- lst ) 99 | 1 'reverse call-emacs-push end-word: 100 | 101 | : map ;; ( sq qtn -- sq ) 102 | () swap ( ( swap cons ) curry dip ) currycompose ( call dup ) curry ( tail/head ) swap compose loop drop reverse 103 | ( call ) curry 104 | ( tail/head ) swap com odpuops e 105 | 106 | PARSING: {-- 107 | ( '--} eq not ) list-until reverse dup print 108 | '( stack-depth push-retain ) swap 2append 109 | '( stack-depth pop-retain - dup >=0? not 110 | ( "expected new elements on the stack in LIST:" error ) when 111 | nlist) 112 | 2append 113 | reverse 114 | list>stack 115 | end-word: 116 | 117 | 118 | : last-case? 119 | 120 | : case ;; 121 | ( tail/head 122 | 123 | : list-between-nested ;; ( els close open -- list ) 124 | ( ( = ) curry ) bi 125 | end-word: 126 | 127 | drop-all '{ 1 2 3 '} '{ ( ( = when ) curry ) bi@ 128 | ( (1 - ) compose ) ( (1 + ) compose ) bi* 129 | 130 | drop-all 1 2 ( 1 + ) bi@ 131 | drop-all 1 2 3 ( 1 + ) keep 132 | drop-all {-- 1 2 3 4 5 --} 133 | 134 | 135 | PARSING: LIST: 136 | ( 'END-LIST: eq not ) list-until reverse dup print 137 | '( stack-depth push-retain ) swap 2append 138 | '( stack-depth pop-retain - dup >=0? not 139 | ( "expected new elements on the stack in LIST:" error ) when 140 | nlist) 141 | 2append 142 | reverse 143 | list>stack 144 | end-word: 145 | 146 | 147 | LIST: "dogs" "cats" "home-" "run" 2concat END-LIST: 148 | drop drop 149 | 150 | 151 | 1 2 3 rot 152 | 153 | 154 | 155 | 156 | 157 | 158 | -------------------------------------------------------------------------------- /def.el: -------------------------------------------------------------------------------- 1 | (require 'monad-parse) 2 | (require 'utils) 3 | 4 | (defun expr->let-clause (expr) 5 | (cond 6 | ((symbolp expr) (lambda 7 | 8 | (defmacro extlet (expr &rest body) 9 | (cond 10 | ((symbolp expr) `( -------------------------------------------------------------------------------- /elab.el: -------------------------------------------------------------------------------- 1 | (defun nilp (x) 2 | (eq nil x)) 3 | 4 | (defun quotep (form) 5 | (and (listp form) 6 | (not (nilp form)) 7 | (equal 'quote (car form)))) 8 | 9 | (setf *matlab-macros* (tbl!)) 10 | (defmacro* defmatlab-macro (name args &body body) 11 | (let ((actual-name (inter (format "%s-elab--" name)))) 12 | `(progn 13 | (defun* ,actual-name ,args ,@body) 14 | (tbl! *matlab-macros* ',name ',actual-name)))) 15 | 16 | 17 | (defun matlab-macrop (symbol) 18 | ($ symbol in *matlab-macros*)) 19 | 20 | (defun expand-matlab-macro (form) 21 | (let ((macro-name (tbl *matlab-macros* (car form))) 22 | (macro-body (cdr form))) 23 | (apply macro-name body))) 24 | 25 | (defun sym->camel-case (s) 26 | (let* ((parts (split-string (format "%s" s) "-")) 27 | (parts (cons (car parts) (mapcar #'capitalize (cdr parts))))) 28 | (apply #'concat parts))) 29 | 30 | (sym->camel-case 'test-this) 31 | 32 | (defun prognp (form) 33 | (and (listp form) 34 | (not (nilp form)) 35 | (equal (car form) 'progn))) 36 | 37 | (defun elab-expand-progn (form) 38 | (let ((parts (mapcar #'form->matlab (cdr form)))) 39 | (format "apply(@(varargin) varargin{end},%s)" 40 | (join parts ", ")))) 41 | 42 | (elab-expand-progn '(progn 1 2 "a"))"apply(@(varargin) varargin{end},1, 2, 'a')" 43 | 44 | (setq double-quote "\"") 45 | (setq single-quote "'") 46 | 47 | (defun form->matlab (form) 48 | (cond ((numberp form) (format "%s" form)) 49 | ((stringp form) 50 | (concat single-quote (replace-regexp-in-string "'" "''" form) single-quote)) 51 | ((symbolp form) (sym->camel-case form)) 52 | ((listp form) 53 | (cond 54 | ((nilp form) "[]") 55 | ((quotep form) "'%s'" (replace-regexp-in-string "'" "''" (form->matlab (cadr form)))) 56 | ((matlab-macrop form) 57 | (form->matlab (expand-matlab-macro form))) 58 | (t 59 | (let ((f-name (sym->camel-case (car form))) 60 | (args (join (mapcar #'form->matlab (cdr form)) ", "))) 61 | (format "%s(%s)" f-name args))))))) 62 | 63 | 64 | (form->matlab '(sin some-data 2)) 65 | 66 | -------------------------------------------------------------------------------- /elcie.el: -------------------------------------------------------------------------------- 1 | (require 'macro-utils) 2 | 3 | (defun dec-name (form) (third form)) 4 | (defun dec-spec (form) (second form)) 5 | 6 | 7 | 8 | (defun emit-binary-operator (op args) 9 | (concat "((" 10 | (join 11 | (mapcar #'compile-elci args) 12 | (format ")%s(" op)) "))")) 13 | 14 | (dont-do 15 | (emit-binary-operator '+ (list 1 2 3 4))) 16 | 17 | (defun* parse-type-expression (form &optional (acc "%s")) 18 | (cond ((symbolp form) (concat (format "%s " form) acc)) 19 | ((vectorp form) 20 | (concat (join (mapcar (lambda (x) (format "%s" x)) (coerce form 'list)) " ") " "acc)) 21 | ((listp form) 22 | (if (< (length form) 2) (error (format "Can't understand form %s." form)) 23 | (let ((type (car form))) 24 | (case type 25 | ('array-of 26 | (parse-type-expression 27 | (cadr form) 28 | (concat "(" acc ")" 29 | (format "[%s]" 30 | (if (> (length form) 2) (elt form 2) ""))))) 31 | ('function-returning 32 | (parse-type-expression (cadr form) (format acc "(%s())"))) 33 | ('pointer-to 34 | (parse-type-expression (cadr form) (concat "*(" acc ")"))) 35 | (otherwise (error (format "Can't understand form %s." form))))))))) 36 | 37 | (defun emit-dec (form) 38 | (let ((name (dec-name form)) 39 | (type-expression (dec-spec form))) 40 | (concat (format (parse-type-expression type-expression "%s") name) ""))) 41 | 42 | (defun emit-symbol (form) 43 | (format "%s" form)) 44 | 45 | (defun literallyp (form) 46 | (and (non-empty-listp form) 47 | (eq (car form) 'literally))) 48 | 49 | (setf *elcie-macros* (tbl!)) 50 | 51 | (defmacro defmacro-elcie (name args &rest body) 52 | `(progn 53 | (defun ,(internf "elcie-macro-%s" name) ,args 54 | ,@body) 55 | (tbl! *elcie-macros* ',name #',(internf "elcie-macro-%s" name)))) 56 | 57 | (defun elcie-macrop (form) 58 | (and (non-empty-listp form) 59 | (in (car form) *elcie-macros*))) 60 | 61 | (defun elcie-macro-expand (form) 62 | (let ((macrof (tbl *elcie-macros* (car form)))) 63 | (apply macrof (cdr form)))) 64 | 65 | (defun emit-elcie-macro (form) 66 | (compile-elci (elcie-macro-expand form))) 67 | 68 | (defun emit-elci-function-call (form) 69 | (let ((fname (car form)) 70 | (args (cdr form))) 71 | (format "%s(%s)" fname 72 | (join (mapcar #'compile-elci args) ",")))) 73 | 74 | (defmacro-elcie progn (&rest body) 75 | `(literally ,(apply #'concat 76 | (mapcar #'compile-elci body)))) 77 | 78 | (defmacro-elcie typedef (type alias) 79 | `(literally ,(concat "typedef " (format (parse-type-expression form) "") " " (format "%s" alias)))) 80 | 81 | (defmacro-elcie include<> (&rest files) 82 | `(literally ,(concat (join (mapcar 83 | (lambda (x) 84 | (format "#include<%s>" x)) 85 | files) (format "\n")) (format "\n")))) 86 | 87 | (defmacro-elcie include (&rest files) 88 | `(literally ,(concat (join (mapcar 89 | (lambda (x) 90 | (format "#include\"%s\"" x)) 91 | files) (format "\n")) (format "\n")))) 92 | 93 | (defun add-semi-if-not-block (s) 94 | (if (string-represents-blockp s) s 95 | (concat s ";"))) 96 | 97 | (defmacro-elcie if (pred true-body &optional false-body) 98 | `(literally ,(format "if(%s) %s %s" 99 | (compile-elci pred) 100 | (add-semi-if-not-block (compile-elci true-body)) 101 | (if false-body (concat "else " (add-semi-if-not-block (compile-elci false-body))) "")))) 102 | 103 | (defun emit-newline () 104 | (format "\n")) 105 | 106 | (defmacro-elcie block (&rest body) 107 | `(literally ,(concat "{" (emit-newline) (join 108 | (loop for form in body collect 109 | (let ((cc (compile-elci form))) 110 | (if (string-represents-blockp cc) 111 | cc 112 | (concat cc ";")))) 113 | (emit-newline)) (emit-newline) "}" (emit-newline)))) 114 | 115 | 116 | (defmacro-elcie fun (out-type name in-types &rest body) 117 | `(literally ,(format "%s %s(%s){\n %s\n }" 118 | (format (parse-type-expression out-type) "") 119 | name 120 | (join (mapcar (lambda (x) (format (parse-type-expression (car x)) (cadr x))) 121 | in-types) ",") 122 | (compile-elci `(block ,@body))))) 123 | 124 | (defmacro-elcie return (val-expr) 125 | `(literally ,(format "return %s" (compile-elci val-expr)))) 126 | 127 | (defun last-character (s) 128 | (let ((n (length s))) 129 | (substring s (- n 1) n))) 130 | 131 | (defun string-represents-blockp (s) 132 | (string= (last-character (chomp s)) "}")) 133 | 134 | (defmacro-elcie dec (type name) 135 | `(literally ,(emit-dec `(dec ,type ,name)))) 136 | 137 | (setf c-binary-operators '(+ - / * & && | || < > == <= >= !=)) 138 | 139 | (loop for op in c-binary-operators do 140 | (eval `(defmacro-elcie ,op (&rest rest) 141 | `(literally ,(emit-binary-operator ',op rest))))) 142 | 143 | (dont-do 144 | 145 | (emit-elcie-macro '(include<> stdio.h stdlib.h math.h)) 146 | (emit-elcie-macro '(include a.h b.h c.h)) 147 | 148 | (emit-elcie-macro '(- 1 2 3)) 149 | 150 | 151 | (elcie-macrop '(dec int x)) 152 | (elcie-macro-expand '(dec int x)) 153 | (emit-elcie-macro '(dec int x)) 154 | 155 | (emit-elcie-macro '(fun int main ((int argc) ((pointer-to (pointer-to char)) argv)) (return (+ argc argc)))) 156 | 157 | (emit-elcie-macro '(block (dec (pointer-to int) x) (dec int y))) 158 | (emit-elcie-macro '(block (dec int x) (dec int y) (dec int z) (if (greater-than x 10) (block (plus x y)) (block (minus x y))))) 159 | 160 | 161 | ) 162 | 163 | (defun compile-elci (form) 164 | (cond 165 | ((numberp form) 166 | (format "%s" form)) 167 | ((stringp form) 168 | (format "\"%s\"" form)) 169 | ((symbolp form) 170 | (emit-symbol form)) 171 | ((listp form) 172 | (cond 173 | ((literallyp form) 174 | (if (< (length form) 2) "" 175 | (cadr form))) 176 | ((elcie-macrop form) 177 | (emit-elcie-macro form)) 178 | (t 179 | (emit-elci-function-call form)))) 180 | ((vectorp form) 181 | (emit-indexing form)))) 182 | 183 | 184 | (dont-do 185 | ((setp form) 186 | (emit-set form)) 187 | ((defp form) 188 | (emit-def form)) 189 | ((ifp form) 190 | (emit-if form)) 191 | ((forp form) 192 | (emit-for form)) 193 | ((switchp form) 194 | (emit-switch form))) -------------------------------------------------------------------------------- /ellision.el: -------------------------------------------------------------------------------- 1 | (defun let-like? (form) 2 | (and (listp form) 3 | (let ((head (first form))) 4 | (foldl 5 | (lambda (it ac) 6 | (or (= it head))) 7 | nil 8 | '(let let* lexical-let lexical-let*))))) 9 | (defun expand-ellision (form) 10 | (cond 11 | ((atom form) form) 12 | ((listp form) 13 | (let* ((head (first form)) 14 | (head-string (format "%s" head)) 15 | (any-& 16 | 17 | (defmacro* with-ellision (&body body) 18 | (let ((exp-body (macroexpand-all body))) 19 | 20 | 21 | (macroexpand-all '(defun f (x) (+ x 1))) 22 | 23 | -------------------------------------------------------------------------------- /esl-mode.el: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VincentToups/emacs-utils/6784d57ea181e815f53881f284db7ab725ba5852/esl-mode.el -------------------------------------------------------------------------------- /esl-readme.md: -------------------------------------------------------------------------------- 1 | Emacs Stack Language 2 | -------------------- 3 | 4 | Have you ever wanted to be as cool as Slava Pestov, all without ever 5 | leaving Emacs? Do you want to write code that looks like this: 6 | 7 | : wrap-interactive ;; ( interactive-sig name -- ) 8 | retain> retain> retain-dup 'defun > 2 '(1 2)) 11 | :history nil)) 12 | 13 | 14 | (game-board->string almost-solved)" 15 | o 16 | o o 17 | o x x 18 | o o o o 19 | o o o o o 20 | " 21 | (game-board->string (car (take-n (game-generate-hops almost-solved) 10)))" 22 | o 23 | o o 24 | x o o 25 | o o o o 26 | o o o o o 27 | " 28 | 29 | (setq novel-solutions 30 | (let* ((init-board (peg-game-board (scar solutions))) 31 | (predicate 32 | (lexical-let ((init-board init-board)) 33 | (lambda (g) 34 | (not (equal (peg-game-board g) init-board)))))) 35 | (remove-until solutions predicate))) 36 | 37 | (tick-tock 38 | (setq solutions 39 | (solve-peg-game centro-c))) 40 | 41 | (loop for s in (take-n solutions 100) do 42 | (insert (game-board->string s))) 43 | 44 | -------------------------------------------------------------------------------- /flotsam/to-lambda-esl.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'defn) 3 | 4 | (setf *esl-stack* nil) 5 | (setf *esl-return-stack*) 6 | 7 | (defn esl-push [item] 8 | ;(print *esl-stack*) 9 | (push item *esl-stack*)) 10 | (defn esl-pop [] 11 | ;(print *esl-stack*) 12 | (if ($ 0 = (length *esl-stack*)) 13 | (error "ESL: stack underflow %s" *esl-stack*)) 14 | (pop *esl-stack*)) 15 | (defn esl-dup [] 16 | (esl-push (car *esl-stack*))) 17 | (defn esl-swap [] 18 | (let ((a (esl-pop)) 19 | (b (esl-pop))) 20 | (esl-push a) 21 | (esl-push b))) 22 | 23 | 24 | (defun esl-mangle (name) 25 | (intern (format "__els-word__%s" name))) 26 | 27 | (defun esl-unmangle (name) 28 | (intern (substring (format "%s" name) 0 12))) 29 | 30 | (defmacro* def-esl-word (name &body body) 31 | `(defun ,(esl-mangle name) () 32 | ,@body)) 33 | 34 | (def-esl-word + (esl-push (+ (esl-pop) (esl-pop)))) 35 | (def-esl-word print (print (esl-pop))) 36 | (def-esl-word drop-all (setf *esl-stack* nil)) 37 | (def-esl-word call (funcall (esl-pop))) 38 | (def-esl-word over (esl-push (cadr *esl-stack*))) 39 | (def-esl-word dip (let ((qtn (esl-pop)) 40 | (hold (esl-pop))) 41 | (esl-push qtn) 42 | (esl-eval-compiled '(__els-word__call)) 43 | (esl-push hold))) 44 | (def-esl-word curry (let ((qtn (esl-pop)) 45 | (it (esl-pop))) 46 | (esl-push `((lambda () (esl-push ,it)) 47 | ,@qtn)))) 48 | (def-esl-word = (esl-push (= (esl-pop) (esl-pop)))) 49 | (def-esl-word not (esl-push (not (esl-pop)))) 50 | 51 | 52 | (defn_ compile-esl [esl-code] 53 | (eval `(function (lambda () 54 | ,@(loop for part in esl-code collect 55 | (cond 56 | ((listp part) 57 | `(esl-push (quote ,(compile-esl part)))) 58 | ((symbolp part) 59 | (progn 60 | (if (not (functionp (esl-mangle part))) 61 | (print (format "warning, kind find word %s" part))) 62 | (list (esl-mangle part)))) 63 | ((or 64 | (numberp part) 65 | (stringp part)) 66 | `(esl-push ,part)))))))) 67 | 68 | (funcall (compile-esl '( drop-all 1 1 + print (1 1 +)))) 69 | (defun bottomless () (bottomless)) 70 | (bottomless) 71 | 72 | 73 | (defun esl-eval-compiled (code) 74 | (funcall code)) 75 | 76 | (esl-eval-compiled (compile-esl '(drop-all 10 20 + print (1 2 + print) call))) 77 | (esl-eval-compiled (compile-esl '( drop-all 1 4 ( + ) curry call print))) 78 | 79 | *esl-stack* 80 | 81 | (setf x 2000) 82 | (let ((x 20)) 83 | (funcall (function (eval `(lambda (y) ,x))) 20)) 84 | 85 | (funcall (eval `(function (lambda (x) ,10))) 100) 86 | -------------------------------------------------------------------------------- /flymake-actionscript/build_manage.rb: -------------------------------------------------------------------------------- 1 | #!ruby 2 | require 'webrick' 3 | include WEBrick 4 | require 'net/http' 5 | require 'fileutils' 6 | 7 | COMPILE_COMMAND = "mxmlc +configname=flex -compiler.warn-no-type-decl=false -compiler.source-path C:/sdfddf/trunk/src C:/boostworthy_animation_v2_1/src/classes C:/corelib/src -file-specs=main.mxml" 8 | 9 | SWF_TO_RUN = "main.swf" 10 | PORT = 2001 11 | HOST = "localhost" 12 | 13 | ############################################ 14 | # If a parameter was provided, take action # 15 | ############################################ 16 | 17 | begin 18 | case ARGV[0] 19 | when "compile" 20 | http = Net::HTTP.new(HOST, PORT) 21 | resp, date = http.get('/compile') 22 | puts resp.body 23 | exit 24 | when "compile_and_show" 25 | http = Net::HTTP.new(HOST, PORT) 26 | resp, date = http.get('/compile_and_show') 27 | puts resp.body 28 | exit 29 | when "exit" 30 | http = Net::HTTP.new(HOST, PORT) 31 | resp, date = http.get('/exit') 32 | puts resp.body 33 | exit 34 | end 35 | rescue => e 36 | puts "Command failed: #{e}" 37 | exit(1) 38 | end 39 | 40 | 41 | ################################################################# 42 | # Otherwise, if there are no parameters, start the build server # 43 | ################################################################# 44 | 45 | def read_to_prompt(f) 46 | f.flush 47 | output = "" 48 | while chunk = f.read(1) 49 | STDOUT.write chunk 50 | output << chunk 51 | if output =~ /^\(fcsh\)/ 52 | break 53 | end 54 | end 55 | STDOUT.write ">" 56 | output 57 | end 58 | 59 | fcsh = IO.popen("fcsh.exe 2>&1", "w+") 60 | read_to_prompt(fcsh) 61 | fcsh.puts COMPILE_COMMAND 62 | read_to_prompt(fcsh) 63 | 64 | 65 | ##################################################### 66 | # Now expose the shell through a small http server # 67 | ##################################################### 68 | 69 | s = HTTPServer.new( 70 | :Port => PORT, 71 | :Logger => Log.new(nil, BasicLog::WARN), 72 | :AccessLog => [] 73 | ) 74 | 75 | s.mount_proc("/compile"){|req, res| 76 | fcsh.puts "compile 1" 77 | output = read_to_prompt(fcsh) 78 | res.body = output 79 | res['Content-Type'] = "text/html" 80 | } 81 | 82 | s.mount_proc("/compile_and_show"){|req, res| 83 | fcsh.puts "compile 1" 84 | output = read_to_prompt(fcsh) 85 | res.body = output 86 | res['Content-Type'] = "text/html" 87 | if output =~ /#{SWF_TO_RUN} \([0-9]/ 88 | system "SAFlashPlayer.exe #{SWF_TO_RUN}" 89 | end 90 | } 91 | 92 | s.mount_proc("/exit"){|req, res| 93 | s.shutdown 94 | fcsh.close 95 | exit 96 | } 97 | 98 | trap("INT"){ 99 | s.shutdown 100 | fcsh.close 101 | } 102 | 103 | s.start 104 | -------------------------------------------------------------------------------- /ftbl.el: -------------------------------------------------------------------------------- 1 | (setf test-alist '( (:a . 10) (:b . "test"))) 2 | 3 | (assoc :a test-alist) -------------------------------------------------------------------------------- /functional.el: -------------------------------------------------------------------------------- 1 | (require 'codewalking-utils) 2 | (require 'utils) 3 | (require 'cl) 4 | 5 | (defmacro defcompose (name &rest fs) 6 | "Defun a new function NAME as a composition of other functions FS. If (car FS) is a string, use this as the doc string." 7 | (let ((args (gensym (format "%s-args" name)))) 8 | (if (stringp (car fs)) 9 | `(defun ,name (&rest ,args) ,(car fs) 10 | (apply (comp ,@(cdr fs)) ,args)) 11 | `(defun ,name (&rest ,args) 12 | (apply (comp ,@fs) ,args))))) 13 | 14 | (defun /|-argpred (x) 15 | (and (symbolp x) 16 | (let* ((strv (format "%s" x)) 17 | (first-char (substring strv 0 1)) 18 | (rest-chars (substring strv 1 (length strv))) 19 | (rest-count (string-to-number rest-chars))) 20 | (and (string= "%" first-char) 21 | (> rest-count 0))))) 22 | 23 | (defun arg-num (arg) 24 | (let* ((strv (format "%s" arg)) 25 | (first-char (substring strv 0 1)) 26 | (rest-chars (substring strv 1 (length strv))) 27 | (rest-count (string-to-number rest-chars))) 28 | rest-count)) 29 | 30 | (defun arg< (arg1 arg2) 31 | (< (arg-num arg1) (arg-num arg2))) 32 | 33 | (defmacro* /| (&body body) 34 | (let* ((expanded (macroexpand-all `(progn ,@body))) 35 | (usage-info (collect-usage-info expanded)) 36 | (args (filter #'/|-argpred (get-unbound-symbols-list usage-info))) 37 | (args (functional-sort args #'arg<))) 38 | `(function (lambda ,args ,expanded)))) 39 | 40 | (defmacro defcurrly-doc (newname doc f &rest args) 41 | "Define a function by left-most partial application with doc string." 42 | (let ((narglist (gensym (format "%s-arglist" newname)))) 43 | `(defun ,newname (&rest ,narglist) 44 | ,doc 45 | (apply ,f ,@args ,narglist)))) 46 | 47 | (defmacro defcurryl-no-doc (newname f &rest args) 48 | "Define a function by left-most partial application without doc string." 49 | (let ((narglist (gensym (format "%s-arglist" newname)))) 50 | `(defun ,newname (&rest ,narglist) 51 | (apply ,f ,@args ,narglist)))) 52 | 53 | (defmacro defcurryl (newname &rest args) 54 | "Define a function with left-most partial application on another function." 55 | `(defcurryl-no-doc ,newname ,@args)) 56 | ;; (if (stringp (car args)) 57 | ;; `(defcurryl-doc ,newname ,(car args) ,@(cdr args)) 58 | ;; `(defcurryl-no-doc ,newname ,@args))) 59 | 60 | (defmacro defcurryr (newname oldname &rest args) 61 | (let ((narglist (gensym (format "%s-arglist" newname)))) 62 | `(defun ,newname (&rest ,narglist) 63 | (apply ,oldname (append ,narglist (list ,@args)))))) 64 | 65 | (defmacro clambdal (oldf &rest args) 66 | (let ((narglist (gensym "clambdal-arglist-"))) 67 | `(lambda (&rest ,narglist) 68 | (apply ,oldf ,@args ,narglist)))) 69 | 70 | (defmacro cl (&rest stuff) 71 | `(clambdal ,@stuff)) 72 | 73 | 74 | (defmacro clambdar (oldf &rest args) 75 | (let ((narglist (gensym "clambdal-arglist-"))) 76 | `(lambda (&rest ,narglist) 77 | (apply ,oldf (append ,narglist (list ,@args)))))) 78 | 79 | (defmacro cr (&rest stuff) 80 | `(clambdar ,@stuff)) 81 | 82 | (defun par (f &rest partially-applied-args) 83 | (lexical-let ((f f) 84 | (partially-applied-args partially-applied-args)) 85 | (lambda (&rest unapplied) 86 | (apply f (append unapplied partially-applied-args))))) 87 | 88 | (defun pal (f &rest partially-applied-args) 89 | (lexical-let ((f f) 90 | (partially-applied-args partially-applied-args)) 91 | (lambda (&rest unapplied) 92 | (apply f (append partially-applied-args unapplied))))) 93 | 94 | (defmacro defdecorated (newname oldname transformer) 95 | (let ((args (gensym (format "%s-decorated-args" newname)))) 96 | `(defun ,newname (&rest ,args) 97 | (apply ,oldname 98 | (funcall ,transformer ,args))))) 99 | 100 | (defmacro lambdecorate (oldf transformer) 101 | (let ((args (gensym (format "decorated-args")))) 102 | `(lambda (&rest ,args) 103 | (apply #',oldf 104 | (funcall #',transformer ,args))))) 105 | 106 | (lex-defun f-and-2 (f1 f2) 107 | (lambda (&rest args) 108 | (and (apply f1 args) 109 | (apply f2 args)))) 110 | 111 | (lex-defun f-and (&rest fs) 112 | (reduce #'f-and-2 fs)) 113 | 114 | (lex-defun f-or-2 (f1 f2) 115 | (lambda (&rest args) 116 | (or (apply f1 args) 117 | (apply f2 args)))) 118 | 119 | (lex-defun f-or (&rest fs) 120 | (reduce #'f-or-2 fs)) 121 | 122 | (lex-defun f-not (f) 123 | (lambda (&rest args) 124 | (not (apply f args)))) 125 | 126 | (lex-defun f-mapcar (f) 127 | (lambda (&rest args) 128 | (apply #'mapcar (cons f args)))) 129 | 130 | (lex-defun decorate-all (f dec) 131 | (lambda (&rest args) 132 | (apply f (mapcar dec args)))) 133 | 134 | (lex-defun decorate-n (f index trans) 135 | (lambda (&rest args) 136 | (let* ((el (elt args index)) 137 | (new (funcall trans el))) 138 | (setf (elt args index) new) 139 | (apply f args)))) 140 | 141 | (lex-defun f-comb-with (f-comb f1 f2) 142 | (lambda (&rest args) 143 | (funcall f-comb (apply f1 args) (apply f2 args)))) 144 | 145 | 146 | (provide 'functional) 147 | -------------------------------------------------------------------------------- /guitar.el: -------------------------------------------------------------------------------- 1 | (defun take-randomly (lst) 2 | (let ((ind (floor (random (length lst))))) 3 | (dloop [index 0 4 | [item & rest] lst 5 | front nil] 6 | (if (= index ind) (list item (append (reverse front) rest)) 7 | (recur (+ 1 index) rest (cons item front)))))) 8 | 9 | (take-randomly '(1 2 3 4 5 6)) 10 | 11 | (defun generate-plucking-pattern () 12 | (dloop [in-strings '(E A D G B e) 13 | out-strings nil] 14 | (if in-strings 15 | (dlet [[item rest] (take-randomly in-strings)] 16 | (recur rest (cons item out-strings))) 17 | out-strings))) 18 | 19 | (generate-plucking-pattern) 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /infix.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'recur) 3 | 4 | (defun op> (op1 op2 op-table) 5 | (> (tbl op-table op1) 6 | (tbl op-table op2))) 7 | 8 | 9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /infix.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:44 2011 3 | ;;; from file /home/toups/elisp/utils/infix.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\207" [require utils recur] 2) 17 | (defalias 'op> #[(op1 op2 op-table) "\303 \"\303\n\"V\207" [op-table op1 op2 tbl] 4]) 18 | -------------------------------------------------------------------------------- /lambda-star.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'functional) 3 | (require 'parse-lambda-list) 4 | (require 'cl) 5 | (provide 'lambda-star) 6 | 7 | (defun car-or-thing (item) 8 | "If ITEM Is a list, return the car, otherwise return the thing itself." 9 | (if (listp item) 10 | (car item) 11 | item)) 12 | (defun cadr-or-nil (item) 13 | "If ITEM Is a list, return the cadr, otherwise return nil." 14 | (if (listp item) 15 | (cadr item) 16 | nil)) 17 | 18 | (defun gen-optional-fill-forms (syms expr) 19 | "Generate forms from SYMS and EXPR for a PSETQ form to set up OPTIONAL ARGS from LAMBDA*" 20 | (loop for sym in syms and exp in expr 21 | when exp 22 | append 23 | (list sym `(if ,sym ,sym ,exp)))) 24 | 25 | (defun gen-key-fill-forms (syms expr alist-name) 26 | "Generate forms from SYMS and EXPR for fill a PSETQ form for keyword args. Use an alist called ALIST-NAME." 27 | (loop for sym in syms and exp in expr 28 | append 29 | (with-gensyms 30 | ((temp sym)) 31 | (list sym 32 | `(let ((,temp (alist ,alist-name ,(symbol->keyword sym)))) 33 | (if ,temp ,temp ,exp)))))) 34 | 35 | (defun optional-and-key->standard-alist&bind-splice (argalist) 36 | "Generate an arg list and a splice of setter code for a optional and key case bind from LAMBDA*" 37 | (let* ((normal (alist argalist :normal)) 38 | (optional (alist argalist :optional)) 39 | (key-part (alist argalist :key)) 40 | (opt-syms (mapcar #'car-or-thing optional)) 41 | (opt-expr (mapcar #'cadr-or-nil optional)) 42 | (rest-name (gensym "&key-rest-")) 43 | (alist-name (gensym "&key-alist-")) 44 | (key-syms (mapcar #'car-or-thing key-part)) 45 | (key-expr (mapcar #'cadr-or-nil key-part))) 46 | (print key-syms) 47 | (list `(,@normal &optional ,@opt-syms &rest ,rest-name) 48 | (list 49 | `(setq ,alist-name (apply #'alist>> ,rest-name)) 50 | `(psetq ,@(gen-optional-fill-forms opt-syms opt-expr) 51 | ,@(gen-key-fill-forms key-syms key-expr alist-name)))))) 52 | 53 | (dont-do 54 | (optional-and-key->standard-alist&bind-splice (alist>> :normal '(a b) :key '(d))) 55 | ) 56 | 57 | (defun key-arg-symbols (argalist) 58 | "Return the symbols associated with key arguments in ARGALIST, a parsed lambda list." 59 | (mapcar #'car-or-thing 60 | (alist argalist :key))) 61 | 62 | (defun lambda*-optional-key-case (argalist body) 63 | "Build a lambda form for a case with OPTIONAL and KEYWORD args." 64 | (let-seq (arglist fill-splice) (optional-and-key->standard-alist&bind-splice argalist) 65 | `(lambda ,arglist 66 | (let ,(key-arg-symbols argalist) 67 | ,@fill-splice ,@body)))) 68 | 69 | (defun lambda*-optional-rest-case (argalist body) 70 | "Build a lambda form for a case with optional and rest forms." 71 | (let* ((normal (alist argalist :normal)) 72 | (rest-name (alist argalist :rest)) 73 | (optional (alist argalist :optional)) 74 | (opt-syms (mapcar #'car-or-thing optional)) 75 | (opt-expr (mapcar #'cadr-or-nil optional))) 76 | `(lambda (,@normal &optional ,@opt-syms ,@(if rest-name '(&rest) nil) ,@(if rest-name (list rest-name) nil)) 77 | (psetq ,@(gen-optional-fill-forms opt-syms opt-expr)) 78 | ,@body))) 79 | 80 | (defmacro* lambda* (arglist &body body) 81 | "Lambda but with Common Lisp lambda-list semantics." 82 | (let ((argalist (parse-lambda-list arglist))) 83 | (cond ((and 84 | (not (alist argalist :optional)) 85 | (not (alist argalist :key))) 86 | `(lambda ,arglist ,@body)) 87 | ((not (alist argalist :rest)) 88 | (lambda*-optional-key-case argalist body)) 89 | ((not (alist argalist :key)) 90 | (lambda*-optional-rest-case argalist body))))) 91 | -------------------------------------------------------------------------------- /later.el: -------------------------------------------------------------------------------- 1 | (require 'cl) 2 | (require 'utils) 3 | 4 | (eval-when-compile-also 5 | (defun single-symbol-list? (item) 6 | (and (listp item) 7 | (= (length item) 1) 8 | (symbolp (car item)))) 9 | (defun binderish? (item) 10 | (and (listp item) 11 | (= (length item) 2) 12 | (symbolp (car item)))) 13 | 14 | (defun with-form->binder (item) 15 | (cond ((symbolp item )(list item item)) 16 | ((listp item) 17 | (cond ((single-symbol-list? item) 18 | (cons (car item) item)) 19 | ((binderish? item) 20 | item) 21 | (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item)))) 22 | (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item)))) 23 | 24 | (defmacro* later (expr &key (with nil) (with* nil)) 25 | (cond (with 26 | `(lexical-let ,(mapcar #'with-form->binder with) 27 | (later ,expr :with* ,with*))) 28 | (with* 29 | `(lexical-let* ,(mapcar #'with-form->binder with*) 30 | (later ,expr))) 31 | (t `(lambda () ,expr))))) 32 | 33 | (provide 'later) 34 | -------------------------------------------------------------------------------- /later.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Wed Jun 8 16:03:25 2011 3 | ;;; from file /home/toups/elisp/utils/later.el 4 | ;;; in Emacs version 23.1.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | (if (and (boundp 'emacs-version) 9 | (< (aref emacs-version (1- (length emacs-version))) ?A) 10 | (or (and (boundp 'epoch::version) epoch::version) 11 | (string-lessp emacs-version "19.29"))) 12 | (error "`later.el' was compiled for Emacs 19.29 or later")) 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | 17 | (byte-code "\300\301!\210\300\302!\207" [require cl utils] 2) 18 | (defalias 'single-symbol-list\? #[(item) "<\205G\301U\205@9\207" [item 1] 2]) 19 | (defalias 'binderish\? #[(item) "<\205G\301U\205@9\207" [item 2] 2]) 20 | (defalias 'with-form->binder #[(item) "9\203 \211D\207<\203&\301!\203@B\207\302!\203!\207\303\304\"\207\303\304\"\207" [item single-symbol-list\? binderish\? error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S."] 3]) 21 | #@55 Not documented 22 | 23 | (fn EXPR &key (WITH nil) (WITH* nil)) 24 | (defalias 'later '(macro . #[(expr &rest #1=#:--cl-rest--) "\305>A@\306>A@ \2038 @\307>\203! AA\211\202\310>A@\203/\311\211\202\312\313 @\"\210\202) \203K\314\315\316 \"\317\f\306\nFE\202_\n\203[\320\315\316\n\"\317\fDE\202_\321\311\fE*\207" [#1# with with* #2=#:--cl-keys-- expr :with :with* (:with :with* :allow-other-keys) :allow-other-keys nil error "Keyword argument %s not one of (:with :with*)" lexical-let mapcar with-form->binder later lexical-let* lambda] 7 (#$ . 1062)])) 25 | (provide 'later) 26 | -------------------------------------------------------------------------------- /lisp-parser.el: -------------------------------------------------------------------------------- 1 | (require 'monad-parse) 2 | (require 'cl) 3 | (provide 'lisp-parser) 4 | 5 | (lexical-let 6 | ((also-ok-in-ids 7 | (coerce "!@$%^&*_+-={}:.?/\|" 'list))) 8 | (defun other-id-char? (x) (in x also-ok-in-ids))) 9 | 10 | (defun =other-id-char () 11 | (=satisfies #'other-id-char?)) 12 | 13 | (funcall (=other-id-char) (->in "|")) 14 | 15 | (defun =id-char () 16 | (parser-plus-2 (alphanumeric) (=other-id-char))) 17 | 18 | (funcall (=id-char) (->in "ab")) 19 | 20 | (defun =lisp-symbol () 21 | (=let* [_ (one-or-more (=id-char))] 22 | (read (coerce _ 'string)))) 23 | 24 | 25 | (defun =numeric-sequence () 26 | (=let* [_ (one-or-more (=digit-char))] 27 | (coerce _ 'string))) 28 | 29 | (defun =int () 30 | (=let* [sign (zero-or-one (=or (=char->string ?-) 31 | (=char->string ?+))) 32 | s (=numeric-sequence)] 33 | (string-to-number (concat sign s)))) 34 | 35 | 36 | (defun =char->string (char) 37 | (=let* [_ (=char char)] 38 | (coerce (list _) 'string))) 39 | 40 | (defun =number () 41 | (=or (=float) (=int))) 42 | 43 | (defun =float () 44 | (=let* [sign (zero-or-one (=or (=char->string ?+) (=char->string ?-))) 45 | p1 (zero-or-more (=digit-char)) 46 | dot (=char ?.) 47 | p2 (one-or-more (=digit-char))] 48 | (string-to-number (concat sign p1 "." p2)))) 49 | 50 | 51 | (defunc =escaped-quote () 52 | (=let* [_ (=string "\\\"")] 53 | (if _ ?\" nil))) 54 | 55 | (setq space ?\s) 56 | 57 | (defun =spaces () 58 | (zero-or-more (=char ?\s))) 59 | (defun =space () 60 | (=char ?\s)) 61 | 62 | (defun =lisp-atom () 63 | (=let* [_ (=spaces) 64 | atom (=or (=number) 65 | (=lisp-string) 66 | (=lisp-symbol)) 67 | ] 68 | atom)) 69 | 70 | (defunc =lisp-string () 71 | (=let* [_ (=char ?\") 72 | contents (zero-or-more (=or 73 | (=escaped-quote) 74 | (=satisfies 75 | (lex-lambda (c) (!= c ?\"))))) 76 | _ (=char ?\")] 77 | (coerce (flatten contents) 'string))) 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /logging.el: -------------------------------------------------------------------------------- 1 | (provide 'logging) 2 | (require 'bigint) 3 | (require 'sqlite) 4 | 5 | (setq *logging-enabled* nil) 6 | (setq *last-buffer-change* "") 7 | 8 | (defun sawfish-like-current-time () 9 | (let* ((days (time-to-number-of-days (current-time))) 10 | (seconds (* (- days (floor days)) (* 24 60 60)))) 11 | (cons (floor days) (floor seconds)))) 12 | 13 | (defun event-log-emacs-sql (raw other-data) 14 | (let* ((ct (sawfish-like-current-time)) 15 | (days (car ct)) 16 | (seconds (cdr ct)) 17 | (cts (current-time-string))) 18 | (print raw) 19 | (atomic-insert "/home/toups/Dropbox/event-log.db" 'events '(days seconds raw date extra) (list days seconds raw cts other-data)))) 20 | 21 | (defun event-logf (&rest args) 22 | (event-log-emacs-sql (apply #'format args) nil)) 23 | (defun event-log-alist (alist) 24 | (event-log-emacs-sql 25 | (if (alist alist 'raw) (alist alist 'raw) "") 26 | alist)) 27 | (defun event-log-alist>> (&rest args) 28 | (event-log-alist (apply #'alist>> args))) 29 | 30 | (defun log-buffer-entry-activity () 31 | (if *logging-enabled* 32 | (let ((name (buffer-name (current-buffer)))) 33 | (if (not (string= name *last-buffer-change*)) 34 | (progn 35 | (event-logf "Switched to %s in emacs" name) 36 | (setq *last-buffer-change* name)))))) 37 | 38 | (comment 39 | (setq *logging-enabled* t) 40 | ) 41 | 42 | 43 | (push #'log-buffer-entry-activity *after-select-window-hooks*) 44 | -------------------------------------------------------------------------------- /match.el: -------------------------------------------------------------------------------- 1 | (require 'monads) 2 | (require 'utils) 3 | (require 'recur) 4 | 5 | (defstruct pdoublet retval rest) 6 | 7 | (defun pdoublet (retval rest) 8 | (make-pdoublet :retval retval :rest rest)) 9 | 10 | (defvar else t) 11 | (defvar otherwise t) 12 | 13 | (lex-defun promote-parser (p) 14 | (cond 15 | ((funcall (f-or #'numberp #'stringp #'symbolp #'keywordp) p) 16 | (lex-lambda (input) 17 | (if (empty? input) input 18 | (let ((first (car input))) 19 | (if (equal p first) (list (pdoublet p (cdr input))) 20 | nil))))) 21 | (else p))) 22 | 23 | (lex-defun promote-parser

(p) 24 | (if (functionp p) p 25 | (lambda (v) (promote-parser p)))) 26 | 27 | (defun these (&rest rest) 28 | (lexical-let ((n (length rest)) 29 | (these these) 30 | (rest rest)) 31 | (lambda (input) 32 | (let-seq (match-these leftover) 33 | (split-after-n input n) 34 | (if (equal match-these rest) 35 | (list (pdoublet match-these leftover)) 36 | nil))))) 37 | 38 | (defun parse-list-bind (parser parser

) 39 | (lexical-let ((parser (promote-parser parser)) 40 | (parser

(promote-parser

parser

))) 41 | (lex-lambda (input) 42 | (if (empty? input) nil 43 | (recur-let 44 | ((prl (funcall parser input)) 45 | (acc '())) 46 | (if (empty? prl) acc 47 | (recur (cdr prl) 48 | (append acc 49 | (let* ((pdoub (car prl)) 50 | (retval (pdoublet-retval pdoub)) 51 | (rest (pdoublet-rest pdoub)) 52 | (newp (promote-parser (funcall parser

retval)))) 53 | (funcall newp rest)))))))))) 54 | 55 | (lex-defun parse-list-return (item) 56 | (lex-lambda (input) 57 | (list (pdoublet item input)))) 58 | 59 | (defun parse-list-plus (p1 p2) 60 | (lexical-let ((p1 (promote-parser p1)) 61 | (p2 (promote-parser p2))) 62 | (lexical-mlet parse-list-monad 63 | ((r1 p1) 64 | (r2 p2)) 65 | (m-return r2)))) 66 | 67 | (lex-defun parse-list-zero (input) 68 | nil) 69 | 70 | (setq parse-list-monad 71 | (tbl! 72 | :m-return #'parse-list-return 73 | :m-bind #'parse-list-bind 74 | :m-plus #'parse-list-plus 75 | :m-zero #'parse-list-zero)) 76 | 77 | (funcall (lexical-mlet parse-list-monad 78 | ((x 'x) 79 | (y 'y)) 80 | (m-return (list x y))) (list 'x 'y)) 81 | 82 | 83 | (lex-defun @or2 (p1 p2) 84 | (lambda (input) 85 | (when input 86 | (let ((r1 (funcall p1 input))) 87 | (if r1 r1 88 | (funcall p2 input)))))) 89 | 90 | (lex-defun @or (&rest ps) 91 | (reduce #'@or2 ps)) 92 | 93 | (lex-defun @and (&rest ps) 94 | (reduce #'parse-list-plus ps)) 95 | 96 | (lex-defun @satisfies (f) 97 | (lambda (input) 98 | (when input 99 | (let ((first (car input)) 100 | (rest (cdr input))) 101 | (if (funcall f first) 102 | (list (pdoublet f rest)) 103 | nil))))) 104 | 105 | (defun @list-of (p) 106 | (lexical-mlet parse-list-monad 107 | ((r p)) 108 | (m-return (list r)))) 109 | 110 | (defun zero-or-more-dealer (dblt p) 111 | (let ((input (pdoublet-rest dblt)) 112 | (lst (pdoublet-retval dblt))) 113 | (let-if rs (funcall p input) 114 | (list :continued 115 | (mapcar 116 | (lambda (dblt) 117 | (let* ((prv (pdoublet-retval dblt)) 118 | (cont (pdoublet-rest dblt))) 119 | (pdoublet (cons prv lst) cont))) rs)) 120 | (list :terminated 121 | (pdoublet (reverse lst) input))))) 122 | 123 | (defun @zero-or-more (p) 124 | (lexical-let ((p (promote-parser p))) 125 | (lambda (input) 126 | (when input 127 | (recur-let 128 | ((rs 129 | (funcall (@list-of p) input)) 130 | (terminals '())) 131 | (let* ((asc 132 | (mapcar/deal (par #'zero-or-more-dealer p) rs)) 133 | (cont (reduce #'append (alist asc :continued))) 134 | (term (alist asc :terminated))) 135 | (if (empty? cont) 136 | (append terminals term) 137 | (recur cont 138 | (append terminals term))))))))) 139 | 140 | (defun @one-or-more (p) 141 | (lexical-let ((p (promote-parser p))) 142 | (lexical-mlet parse-list-monad 143 | ((one p) 144 | (more (@zero-or-more p))) 145 | (m-return (cons one more))))) 146 | 147 | 148 | (funcall (@zero-or-more 'x) '(x x x )) 149 | 150 | (funcall (promote-parser 'x) '(x x x x)) 151 | -------------------------------------------------------------------------------- /monad-parse-scratch.el: -------------------------------------------------------------------------------- 1 | (require 'monad-parse) 2 | 3 | (lex-defun =string-flat (str) 4 | (lexical-let ((lst-str (coerce str 'list))) 5 | (foldl 6 | (lex-lambda (char parser-acc) 7 | (=and parser-acc (=char char))) 8 | (=char (car lst-str)) 9 | (cdr lst-str)))) 10 | 11 | (lex-defun =string-flat (str) 12 | (apply #'=and-concat (mapcar #'=char->string (coerce str 'list)))) 13 | 14 | (loop for (a . b) in '( (hey . yeah) (yo . uh) ) collect (list a b)) 15 | 16 | (funcall (parser-items->string (length "test")) (->in "test a test")) 17 | (funcall (parser-item) (->in "test")) 18 | 19 | (funcall (=string "test a test") (->in "test a test")) 20 | 21 | (string= nil "test") 22 | 23 | (funcall (zero-or-more (=char->string ?a)) (->in "aaab")) 24 | 25 | (funcall (parser-bind 26 | (zero-or-more (=char->string ?a)) 27 | (lex-lambda (value) (parser-return (apply #'concat value)))) (->in "aaab")) 28 | 29 | (lex-defun parser-concat (parser) 30 | (parser-bind parser 31 | (lex-lambda (value) (parser-return (apply #'concat value))))) 32 | 33 | (equal (parser-concat (=char->string ?a)) 34 | (parser-bind 35 | (zero-or-more (=char->string ?a)) 36 | (lex-lambda (value) (parser-return (apply #'concat value))))) 37 | (funcall (parser-concat (=char->string ?a)) 38 | (->in "aaab")) 39 | 40 | 41 | (lex-defun parser-apply (parser f) 42 | (parser-bind 43 | parser 44 | (lex-lambda (value) 45 | (parser-return (apply f value))))) 46 | 47 | 48 | (parser-apply (funcall (zero-or-one (=char->string ?a)) (->in "aaab")) #'concat) -------------------------------------------------------------------------------- /monad-parse.md: -------------------------------------------------------------------------------- 1 | Monadic Parser Combinators, in Emacs Lisp 2 | ----------------------------------------- 3 | 4 | I've put together rudimentary (at the moment underdocumented) support 5 | for a parser monad in `monad-parse.el`. This library is something of 6 | a shambling mongrel. Obviously, it is in emacs lisp, but it is built 7 | on top of my implementation of monads and destructuring bind from 8 | Clojure, but it is based on [a monadic parser combinator 9 | library called Smug](http://common-lisp.net/~dcrampsie/smug.html) implemented by 10 | Drew Crampsie in Common Lisp. 11 | 12 | This was a tricky thing to get right, even with all the plumbing 13 | provided by the code in `monads.el` because monadic parsers depend a 14 | lot on lexical scope, which can be simulated in emacs lisp, but you 15 | have to do it explicitely. 16 | 17 | Things are basically just like Drew Crampsie's library except that 18 | I've used my `domonad` form to support his `=let*` form, and as a 19 | consequence the binding forms in that expression follow the clojure 20 | style, rather than the Common Lisp/Emacs Lisp style. This means that 21 | his `results` are my `returns,` and for simplicity I provide 22 | `parser-bind` and `parser-result` global function bindings. Lots of 23 | the functions in Smug have a `parser-` prefix because Emacs Lisp lacks 24 | a good namespace mechanism. `=let*`, in a giant gotcha, automatically 25 | applies `parser-return` to its `body`, so you don't need to indicate 26 | `return` when using it. Besides that, its very similar. 27 | 28 | For instance, using Smug, `zero-or-more` looks like: 29 | 30 | (defun zero-or-more (parser) 31 | (=or 32 | (=let* 33 | ((x parser) 34 | (xs (zero-or-more parser))) 35 | (result (cons x xs))) 36 | (result nil))) 37 | 38 | In this library, which lacks a snappy name because it is too 39 | frankensteinish and slow to be really usable (probably), this would 40 | be: 41 | 42 | (lex-defun zero-or-more (parser) 43 | (=or 44 | (=let* 45 | [x parser 46 | xs (zero-or-more parser)] 47 | (cons x xs)) 48 | (parser-return nil))) 49 | 50 | The differences are: Because `=let*` is producing a function, you need 51 | a lexical closure over `parser`, so I use my `lex-defun` form to 52 | create it. The binding forms in `=let*` use `[]` and no internal 53 | delimiters, and the body of `=let*` doesn't require a `parser-return` function. 54 | 55 | `=let*` is (for reference) literally implemented as: 56 | 57 | (defmacro* =let* (bindings &body body) 58 | `(domonad monad-parse ,bindings ,@body)) 59 | 60 | I may provide a Smug compliant version of `=let*` eventually. 61 | 62 | One other major difference is that you've got to jump through a hoop 63 | to support generic input types. I've used 64 | [eieio](http://cedet.sourceforge.net/eieio.shtml) to provide the 65 | interface for a parsing input stream. Right now, only strings are 66 | supported as parsing streams, but I want to be able to add parsing buffers 67 | cheaply in the future. As a consequence, I've wrapped a string up in 68 | an eieio class `` with methods `input-empty?`, 69 | `input-empty-p` (synonyms), `input-rest`, and `input-first`. Because 70 | eieio doesn't cover the whole emacs class universe, you've got to wrap 71 | a string before using it via `string->parser-input.` 72 | 73 | Reading about [Smug](http://common-lisp.net/~dcrampsie/smug.html) is 74 | probably a great place to start if you want to understand this 75 | library, with the above provisos. Here is an example, though: 76 | 77 | (lexical-let ((digits (coerce "1234567890" 'list))) 78 | (defun digit-char? (x) 79 | (in x digits))) 80 | 81 | (lexical-let ((lowers (coerce "abcdefghijklmnopqrztuvwxyz" 'list)) 82 | (uppers (coerce "ABCDEFGHIJKLMNOPQRZTUVWXYZ" 'list))) 83 | (defun upper-case-char? (x) 84 | (in x uppers)) 85 | (defun lower-case-char? (x) 86 | (in x lowers))) 87 | 88 | (defun =char (x) 89 | (lexical-let ((x x)) 90 | (=satisfies (lambda (y) (eql x y))))) 91 | (defun =upper-case-char? () 92 | (=satisfies (lambda (y) (upper-case-char? y)))) 93 | (defun =lower-case-char? () 94 | (=satisfies (lambda (y) (lower-case-char? y)))) 95 | 96 | (defun =digit-char () 97 | (=satisfies #'digit-char?)) 98 | 99 | (defun letter () (parser-plus (=lower-case-char?) (=upper-case-char?))) 100 | 101 | (defun alphanumeric () (parser-plus (=digit-char) (letter))) 102 | 103 | (funcall (zero-or-more (alphanumeric)) (string->parser-input "aaaa?")) 104 | 105 | 106 | Have fun! 107 | 108 | Disclaimer: This library depends on so much insanity that I cannot 109 | guarantee that it will function as advertised or that it will not 110 | make you lose your mind. 111 | 112 | Notes on the monad. 113 | ------------------- 114 | 115 | This library is obviously monadic, but what is the monad? Well, it 116 | its the parser monad. Monadic values are functions which accept a 117 | value and return a parser, which is itself a function which accepts an 118 | input and returns a list of possible parsing results, which are 119 | value/post-input pairs. It is useful to examine the return operation 120 | of any monad to understand what the monadic values are (in statically 121 | typed languages, you can also see the contained type in the type of 122 | the input argument. In our case, its just "lisp values".) 123 | 124 | (defun parser-return (val) 125 | (lexical-let ((val val)) 126 | (lambda (input) 127 | (list (cons val input))))) 128 | 129 | Return takes a value, and returns a (monadic) function (of the list of 130 | value/input pairs monad, as an aside). The type of this function is 131 | input -> (list Pair). Ok, these functions from inputs to 132 | value/post-input pairs are MONADIC VALUES. What are MONADIC 133 | FUNCTIONS? 134 | 135 | Well, they are functions like BIND. They take a value and return a 136 | MONADIC VALUE. That is, they are functions of values which return 137 | functions of inputs which return lists of pairs of values and inputs. 138 | 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /monad-stream.el: -------------------------------------------------------------------------------- 1 | (require 'monads) 2 | 3 | (eval-when-compile-also 4 | (defun stream-case-names (sub-form) 5 | (car sub-form)) 6 | 7 | (defun stream-case-one (sub-form stream) 8 | (let ((names (stream-case-names sub-form))) 9 | `((not (and (pair? ,stream) 10 | (functionp (cdr ,stream)))) 11 | (let ((,(car names) (car ,stream))) 12 | ,@(cdr sub-form))))) 13 | 14 | (defun stream-case-more (sub-form stream) 15 | (let ((names (stream-case-names sub-form)) 16 | (body (cdr sub-form))) 17 | `(t (let ((,(car names) (car ,stream)) 18 | (,(cadr names) (cdr ,stream))) 19 | ,@body)))) 20 | 21 | (defmacro stream-case (expr on-zero on-one on-more) 22 | (with-gensyms 23 | (stream) 24 | `(let ((,stream ,expr)) 25 | (cond 26 | ((not ,stream) ,on-zero) 27 | ,(stream-case-one on-one stream) 28 | ,(stream-case-more on-more stream)))))) 29 | 30 | (defun stream-cdr (stream) 31 | (stream-case stream 32 | (nil) 33 | ((a) nil) 34 | ((a f) (funcall f)))) 35 | 36 | (defmacro mk-stream (car expr) 37 | `(cons ,car (lambda nil ,@expr))) 38 | 39 | 40 | 41 | (eval-when-compile-also 42 | 43 | (defmacro choice (a &optional f) 44 | `(cons ,a ,f)) 45 | 46 | (defun transform-binder (binder) 47 | (cond 48 | ((symbolp binder) `(,binder ,binder)) 49 | ((listp binder) 50 | (cond 51 | ((= 1 (length binder)) 52 | (let ((s (car binder))) 53 | `(,s ,s))) 54 | ((= 2 (length binder)) 55 | binder))) 56 | (t (error "mk-stream-close needs binders which are symbols, lists of one symbol, or a let-like bind pair.")))) 57 | 58 | (defmacro mk-stream-close (binders car expr) 59 | `(lexical-let 60 | ,(mapcar #'transform-binder binders) 61 | (cons ,car ,expr))) 62 | 63 | 64 | (defun ->choice*binders (thing) 65 | (cond 66 | ((symbolp thing) `((,thing ,thing))) 67 | ((listp thing) (mapcar #'transform-binder thing)))) 68 | 69 | 70 | (defmacro* choice* (a &optional f &key (with nil)) 71 | `(lexical-let ,(->choice*binders with) 72 | (cons ,a ,f))) 73 | ) 74 | (example 75 | (let ((stream (let ((q 10)) 76 | (choice* 33 (lambdac () (+ 1 q)) :with (q))))) 77 | (stream-cdr stream)) 78 | ) 79 | 80 | (defun stream-zero () 81 | nil) 82 | (defvar stream-zero nil "Stream monad zero.") 83 | 84 | (defun stream-unit (x) 85 | (stream-return x)) 86 | 87 | (defun stream-plus (stream f) 88 | (db-print stream) 89 | (db-print f) 90 | (stream-case stream 91 | (funcall f) 92 | ((a) (cons a f)) 93 | ((a f0) (cons a 94 | (lambda () (stream-plus (funcall f0) f)) :with (f f0))))) 95 | 96 | (defun stream-plus^i (stream f) 97 | (stream-case stream 98 | (funcall f) 99 | ((a) (cons a f)) 100 | ((a f0) (choice* a 101 | (stream-plus^i (funcall f) f0))))) 102 | 103 | (defun stream-bind (stream g) 104 | (stream-case stream 105 | (stream-zero) 106 | ((a) (funcall g a)) 107 | ((a f) (stream-plus (funcall g a) 108 | (lexical-let ((f f) 109 | (g g)) 110 | (lambda () 111 | (stream-bind (funcall f) g))))))) 112 | 113 | (defun stream-bind^i (stream g) 114 | (stream-case stream 115 | (stream-zero) 116 | ((a) (funcall g a)) 117 | ((a f) (stream-plus^i (funcall g a) 118 | (lexical-let ((f f) 119 | (g g)) 120 | (lambda () 121 | (stream-bind^i (funcall f) g))))))) 122 | 123 | (defun %fail (s) (stream-zero)) 124 | (defvar %fail #'%fail) 125 | 126 | (defun %succeed (s) (stream-unit s)) 127 | (defvar %succeed #'%succeed) 128 | 129 | (defvar %s %succeed) 130 | (defvar %u %fail) 131 | 132 | (defun stream-return (x) 133 | (cons x nil)) 134 | 135 | (defvar monad-stream 136 | (tbl! :m-bind #'stream-bind 137 | :m-return #'stream-return 138 | :m-zero #'stream-zero)) 139 | 140 | 141 | (defvar monad-stream^i 142 | (tbl! :m-bind #'stream-bind^i 143 | :m-return #'stream-return 144 | :m-zero #'stream-zero)) 145 | 146 | (eval-when-compile-also 147 | (defmacro stream (&rest expressions) 148 | (cond 149 | ((not expressions) 150 | nil) 151 | ((= 1 (length expressions)) 152 | `(choice ,(car expressions) nil)) 153 | (t 154 | `(choice ,(car expressions) 155 | (lambda () 156 | (stream ,@(cdr expressions)))))))) 157 | 158 | (defmacro streamc (&rest expressions) 159 | (cond 160 | ((not expressions) 161 | nil) 162 | ((= 1 (length expressions)) 163 | `(choice ,(car expressions) nil)) 164 | (t 165 | `(choice ,(car expressions) 166 | (lambdac () 167 | (stream ,@(cdr expressions))))))) 168 | 169 | 170 | (defun stream-cdr (stream) 171 | (stream-case stream 172 | nil 173 | ((a) nil) 174 | ((a f) (funcall f)))) 175 | 176 | (defun stream-car (stream) 177 | (stream-case stream 178 | nil 179 | ((a) a) 180 | ((a f) a))) 181 | 182 | (defvar ones (choice 1 (lambda () ones)) 183 | "An infinite stream of ones.") 184 | (defvar zeros (choice 1 (lambda () zeros)) 185 | "An infinite stream of zeros.") 186 | 187 | (defun nums-from (n) 188 | "Return a stream of numbers from N to infinity." 189 | (choice* n (lambda () (nums-from (+ n 1))) :with n)) 190 | 191 | (defvar positive-integers 192 | (nums-from 1) "An infinite stream of integers.") 193 | 194 | 195 | 196 | (recur-defun* take-n (stream n &optional output) 197 | (if (= n 0) (reverse output) 198 | (stream-case 199 | stream 200 | (reverse output) 201 | ((a) (reverse (cons a output))) 202 | ((a f) 203 | (recur (stream-cdr stream) 204 | (- n 1) 205 | (cons a output)))))) 206 | 207 | 208 | (defvar fibs (choice 1 (lambda () 209 | (choice 1 210 | (lambda () 211 | (mlet* monad-stream 212 | ((a fibs) 213 | (b (stream-cdr fibs))) 214 | (+ a b))))))) 215 | (provide 'monad-stream) 216 | 217 | 218 | 219 | -------------------------------------------------------------------------------- /monad-text-parse.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'monads) 3 | (require 'recur) 4 | 5 | (defmacro when/not-empty (val &rest body) 6 | (with-gensyms 7 | (id) 8 | `(let ((,id ,val)) 9 | (when (and ,id (not (empty? ,id))) 10 | ,@body)))) 11 | 12 | (defun match-string< (str) 13 | (let ((str (format "%s" str))) 14 | (enclose 15 | (str) 16 | (lambda (input) 17 | (when input 18 | (let* ((n (length str)) 19 | (k (min (length input) n)) 20 | (test (substring input 0 k)) 21 | (rest (substring input k))) 22 | (if (string= test str) 23 | (list (cons str rest)) 24 | nil))))))) 25 | 26 | (defun ->parser (thing) 27 | (if (functionp thing) thing 28 | (match-string< thing))) 29 | 30 | (defun text-parse-bind (parser* parser-producer) 31 | (let ((parser* (->parser parser*))) 32 | (enclose 33 | (parser* parser-producer) 34 | (lambda (input) 35 | (when input 36 | (recur-let 37 | ((results (funcall parser* input)) 38 | (output '())) 39 | (cond ((empty? results) output) 40 | (t 41 | (printf "results %s" results) 42 | (let* ((first-pair (car results)) 43 | (rest-pairs (cdr results)) 44 | (new-parser (->parser (funcall parser-producer (car first-pair)))) 45 | (new-results (funcall new-parser (cdr first-pair)))) 46 | (recur rest-pairs (append output new-results))))))))))) 47 | 48 | (defun text-parse-return (item) 49 | (enclose 50 | (item) 51 | (lambda (input) 52 | (list (cons item input))))) 53 | 54 | (defun string-head (s) 55 | (if (empty? s) s 56 | (substring s 0 1))) 57 | 58 | (defun string-tail (s) 59 | (if (empty? s) "" 60 | (substring s 1))) 61 | 62 | (defun /item/ (input) 63 | (when/not-empty input 64 | (list (cons (string-head input) (string-tail input))))) 65 | 66 | (defun list-of< (p) 67 | (lexical-mlet 68 | monad-text-parse 69 | ((r p)) 70 | (m-return (list r)))) 71 | 72 | (defun zero-or-more-dealer< (pair p) 73 | (let* ((retval (car pair)) 74 | (rest-input (cdr pair)) 75 | (r (funcall p rest-input))) 76 | (if r 77 | (list :continued 78 | (mapcar 79 | (lambda (pair) 80 | (let ((inner-retval (car pair)) 81 | (leftover-input (cdr pair))) 82 | (cons (cons inner-retval retval) leftover-input))) 83 | r)) 84 | (list :terminated 85 | (cons (reverse retval) rest-input))))) 86 | 87 | (defun zero-or-more< (p) 88 | (enclose 89 | (p) 90 | (lambda (input) 91 | (recur-let 92 | ((terminals '()) 93 | (results (funcall p input))) 94 | (if (empty? results) terminals 95 | (let* ((asc (mapcar/deal (par #'zero-or-more-dealer< p) results)) 96 | (cont (reduce #'append (alist asc :continued))) 97 | (term (alist asc :terminated))) 98 | (if (empty? cont) 99 | (append terminals term) 100 | (recur cont 101 | (append terminals term))))))))) 102 | 103 | (defun one-or-more< (p) 104 | (enclose (p) 105 | (lexical-mlet monad-text-parse 106 | ((r p) 107 | (rest (zero-or-more< p))) 108 | (m-return (cons r rest))))) 109 | 110 | (setq monad-text-parse 111 | (tbl! :m-return #'text-parse-return 112 | :m-bind #'text-parse-bind)) 113 | 114 | (funcall (lexical-mlet monad-text-parse 115 | ((a "a") 116 | (b "b")) 117 | (m-return (list a b))) "ab") 118 | 119 | (funcall (lexical-mlet monad-text-parse 120 | ((r (zero-or-more< (->parser "a")))) 121 | (m-return r)) 122 | "aaaaaab") 123 | 124 | (provide 'monad-text-parse) 125 | 126 | 127 | -------------------------------------------------------------------------------- /monad-text-parse.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Wed Sep 21 14:36:13 2011 3 | ;;; from file /home/toups/elisp/utils/monad-text-parse.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\210\300\303!\207" [require utils monads recur] 2) 17 | (defalias 'when/not-empty '(macro . #[(val &rest body) "\303\304!\305 DC\306\307\310\311DDE\nBBE)\207" [id val body gensym "id" let when and not empty\?] 8])) 18 | (defalias 'match-string< #[(str) "\302\303\"\304\305!\211L\210\306\307\310\311\312 D\313FE*\207" [str #1=#:--cl-str-- format "%s" make-symbol "--str--" lambda (&rest --cl-rest--) apply #[(#2=#:G26426 input) "\205$ JGG\n^\306 O \307O\f J\230\205# J BC,\207" [input #2# n k test rest 0 nil] 3] quote --cl-rest--] 7]) 19 | (defalias '->parser #[(thing) "\301!\203\207\302!\207" [thing functionp match-string<] 2]) 20 | (defalias 'text-parse-bind #[(parser* parser-producer) "\304!\305\306!\305\307!\211L\210 L\210\310\311\312\313\314 D\314\nD\315\257E+\207" [parser* #1=#:--cl-parser-producer-- #2=#:--cl-parser*-- parser-producer ->parser make-symbol "--parser*--" "--parser-producer--" lambda (&rest --cl-rest--) apply #[(#3=#:G26485 #4=#:G26486 input) "\205R\306\307 J!\307\n\203O\307\310 !\203\f\202K\311\312 \"\210 @ A\313J @!!\211 A!\306\314\f\",\307\202* *\207" [input #5=#:recur-loop-return-value-26428 #6=#:recur-loop-sentinal-26427 #4# output results t nil empty\? printf "results %s" ->parser append first-pair rest-pairs #3# new-parser new-results] 4] quote --cl-rest--] 8]) 21 | (defalias 'text-parse-return #[(item) "\302\303!\211 L\210\304\305\306\307\310D\311FE)\207" [#1=#:--cl-item-- item make-symbol "--item--" lambda (&rest --cl-rest--) apply #[(#2=#:G26487 input) "J BC\207" [#2# input] 2] quote --cl-rest--] 7]) 22 | (defalias 'string-head #[(s) "\301!\203\207\302\303O\207" [s empty\? 0 1] 3]) 23 | (defalias 'string-tail #[(s) "\301!\203\302\207\303\304O\207" [s empty\? "" 1 nil] 3]) 24 | (defalias '/item/ #[(input) "\211\205\302 !?\205\303!\304!BC)\207" [input #1=#:id26488 empty\? string-head string-tail] 4]) 25 | (byte-code "\306\307\310\311\312$\211\313 \314\"\315 !\204\316\317!\210\320\321!\211\205\"\321K\322\216\321\323M\210\320\324!\211\2053\324K2\325\216\324\326M\210\320\327!\2113\205F\327K4\330\216\327\331M\210\320\332!\2115\205Y\332K6\333\216\332\334M\210\335\336!\2117 L\210\335\337!\2118\3137J\314\"L\210\3157J!\204\204\316\317!\210\335\340!\335\341!\335\342!\335\343!9:;\211<\344L\210;\344L\210:\344L\2109\344L\210<\345\346\347\350\3519D\351:D\351;D\351>= ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#5=#:--cl-letf-bound-- #6=#:--cl-letf-save-- >>= fmakunbound] 2)) #[(v f) "\303\304\" \n\"\207" [current-monad v f tbl :m-bind] 3] m-plus ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#7=#:--cl-letf-bound-- #8=#:--cl-letf-save-- m-plus fmakunbound] 2)) #[(mv1 mv2) "\303\304\" \n\"\207" [current-monad mv1 mv2 tbl :m-plus] 3] make-symbol "--current-monad--" "--m-zero--" "----cl-var--26492--" "----cl-var--26491--" "----cl-var--26490--" "----cl-var--26489--" nil lambda #9=(&rest --cl-rest--) apply #[(#:G26493 #:G26494 #:G26495 #:G26496 #:G26497 #10=#:G26498 mv1 mv2) "\303J\304\" \n\"\207" [#10# mv1 mv2 tbl :m-plus] 3] quote --cl-rest-- #[(#:G26499 #:G26500 #:G26501 #:G26502 #:G26503 #11=#:G26504 v f) "\303J\304\" \n\"\207" [#11# v f tbl :m-bind] 3] #[(#:G26505 #:G26506 #:G26507 #:G26508 #:G26509 #12=#:G26510 v) "\302J\303\" !\207" [#12# v tbl :m-return] 3] #[(#:G26511 #:G26512 #:G26513 #:G26514 #:G26515 #13=#:G26516 v f) "\303J\304\" \n\"\207" [#13# v f tbl :m-bind] 3] "a" #[(#14=#:G26524 #15=#:G26525 #16=#:G26526 #17=#:G26527 #18=#:G26528 #19=#:G26529 a) "\306\307!\211 L\210\nJ\310\311\312\313\314\315D\315\nD\315 D\315\fD\315 D\315D\315D\316\257\nE\")\207" [#:--cl-a-- a #14# #15# #16# #17# make-symbol "--a--" "b" lambda #9# apply #[(#20=#:G26517 #:G26518 #21=#:G26519 #:G26520 #:G26521 #:G26522 #:G26523 b) "\304\305!\211 L\210\nJ JJD!)\207" [#:--cl-b-- b #21# #20# make-symbol "--b--"] 4] quote --cl-rest-- #18# #19#] 15] "ab" provide #4# #5# #6# #7# #8# #:--cl-current-monad-- #:--cl-m-zero-- #:--cl---cl-var--26489-- #:--cl---cl-var--26490-- #:--cl---cl-var--26491-- #:--cl---cl-var--26492--] 14) 26 | -------------------------------------------------------------------------------- /monad-transformers.el: -------------------------------------------------------------------------------- 1 | (provide 'monad-transformers) 2 | (require 'monads) 3 | (require 'utils) 4 | 5 | (defun seq-t (inner-monad) 6 | (lexical-let ((inner-monad inner-monad)) 7 | (tbl! 8 | :m-return 9 | (lambda (val) 10 | (call-return inner-monad (list val))) 11 | :m-bind 12 | (lex-lambda (mv mf) 13 | (call-bind inner-monad 14 | mv 15 | (lambda (seq) 16 | (reduce (m-lift-into 2 #'swons inner-monad) 17 | (reverse (mapcat mf seq)) 18 | :initial-value (call-return inner-monad nil)))))))) 19 | 20 | (defun state-t (inner-monad) 21 | "Produce a monad by transforming INNER-MONAD with STATE-MONAD properties." 22 | (lexical-let ((inner-monad inner-monad)) 23 | (tbl! 24 | :m-return 25 | (lex-lambda (val) 26 | (call-return inner-monad (lambda (state) (list val state)))) 27 | :m-bind 28 | (lex-lambda (mv mf) 29 | (lex-lambda (state) 30 | (call-bind inner-monad 31 | mv 32 | (lambda (state-fun) 33 | (let-seq (val new-state) 34 | (funcall state-fun state) 35 | (let ((new-f (funcall mf val))) 36 | (funcall new-f new-state)))))))))) 37 | 38 | -------------------------------------------------------------------------------- /monad-tut-examples.el: -------------------------------------------------------------------------------- 1 | (require 'monads) 2 | (require 'functional) 3 | (require 'utils) 4 | 5 | 6 | (defvar *people* '(:ted :lea :leo :james :harvey :sally :jane :andrew :catherine) "A list of all the people that matter.") 7 | (defvar *friends-db* 8 | '((:ted (:lea :leo :sally :andrew :catherine :leo :jane)) 9 | (:lea (:ted :leo :jane :andrew :harvey :sally :catherine)) 10 | (:leo (:ted :lea :ted :harvey :sally :jane :andrew :catherine 11 | :harvey :andrew :catherine)) 12 | (:james (:jane :harvey :jane)) 13 | (:harvey (:leo :lea :leo :james :harvey :harvey :sally)) 14 | (:sally (:ted :leo :lea :harvey :jane :andrew)) 15 | (:jane (:lea :leo :james :sally :ted :james :andrew :catherine)) 16 | (:andrew (:ted :lea :leo :sally :jane :leo)) 17 | (:catherine (:ted :leo :lea :leo :jane :catherine :catherin))) "Our database of friend connections.") 18 | 19 | (defun friends-of (person) 20 | "Return a list of all the people in friends-db." 21 | (alist *friends-db* person) 22 | ;alist is a function which retrieves 23 | ;a key's data from an association list. 24 | ) 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /monad-tut-examples.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:43 2011 3 | ;;; from file /home/toups/elisp/utils/monad-tut-examples.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\210\300\303!\207" [require monads functional utils] 2) 17 | #@39 A list of all the people that matter. 18 | (defvar *people* '(:ted :lea :leo :james :harvey :sally :jane :andrew :catherine) (#$ . 604)) 19 | #@37 Our database of friend connections. 20 | (defvar *friends-db* '((:ted (:lea :leo :sally :andrew :catherine :leo :jane)) (:lea (:ted :leo :jane :andrew :harvey :sally :catherine)) (:leo (:ted :lea :ted :harvey :sally :jane :andrew :catherine :harvey :andrew :catherine)) (:james (:jane :harvey :jane)) (:harvey (:leo :lea :leo :james :harvey :harvey :sally)) (:sally (:ted :leo :lea :harvey :jane :andrew)) (:jane (:lea :leo :james :sally :ted :james :andrew :catherine)) (:andrew (:ted :lea :leo :sally :jane :leo)) (:catherine (:ted :leo :lea :leo :jane :catherine :catherin))) (#$ . 742)) 21 | #@48 Return a list of all the people in friends-db. 22 | (defalias 'friends-of #[(person) "\302 \"\207" [*friends-db* person alist] 3 (#$ . 1334)]) 23 | -------------------------------------------------------------------------------- /monadic-bind.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VincentToups/emacs-utils/6784d57ea181e815f53881f284db7ab725ba5852/monadic-bind.png -------------------------------------------------------------------------------- /monadic-types-of-interest.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VincentToups/emacs-utils/6784d57ea181e815f53881f284db7ab725ba5852/monadic-types-of-interest.png -------------------------------------------------------------------------------- /monads.asd: -------------------------------------------------------------------------------- 1 | ;;;; monads.asd 2 | 3 | (asdf:defsystem #:nil 4 | :serial t 5 | :depends-on (#:lisp-unit 6 | #:shadchen) 7 | :components ((:file "package") 8 | (:file "nil"))) 9 | 10 | -------------------------------------------------------------------------------- /monads.lisp: -------------------------------------------------------------------------------- 1 | ;;;; monads.lisp 2 | 3 | (in-package #:nil) 4 | 5 | ;;; nil goes here. Hacks and glory await! 6 | 7 | -------------------------------------------------------------------------------- /mstack.el: -------------------------------------------------------------------------------- 1 | (require 'monads) 2 | (require 'utils) 3 | 4 | (defun get-options (options) (cdr options)) 5 | (defun options? (mb-options) 6 | (and (listp mb-options) 7 | (eq (car mb-options) 'Options))) 8 | (defun list->options (lst) 9 | (cons 'Options lst)) 10 | 11 | 12 | (defun options-bind (v f) 13 | (let ((options (get-options v))) 14 | (list->options (mapcat (comp #'get-options f) options)))) 15 | 16 | (defvar options-monad 17 | (tbl! 18 | :m-bind 19 | #'options-bind 20 | :m-return 21 | (lex-lambda (v) 22 | (list->options (list v)))) 23 | "Options monad - just window dressing on the list monad.") 24 | 25 | 26 | (defun fpush (x stack) (cons x stack)) 27 | (defun fdrop (stack) (cdr stack)) 28 | 29 | (defun mfpush (mitems mstack) 30 | (funcall (m-lift-into2 #'fpush options-monad) mitems mstack)) 31 | (defun mfdrop (mstack) 32 | (funcall (m-lift-into1 #'fdrop options-monad) mstack)) 33 | 34 | (mfdrop (mfpush '(Options a b c) '(Options () (a) (a a)))) 35 | 36 | (domonad options-monad 37 | [x '(Options 1 2 3) 38 | y '(Options 4 5 6)] 39 | (list x y)) 40 | 41 | (get-options '(Options a b c)) -------------------------------------------------------------------------------- /mstack.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:42 2011 3 | ;;; from file /home/toups/elisp/utils/mstack.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\207" [require monads utils] 2) 17 | (defalias 'get-options #[(options) "A\207" [options] 1]) 18 | (defalias 'options\? #[(mb-options) "<\205 @\301=\207" [mb-options Options] 2]) 19 | (defalias 'list->options #[(lst) "\301B\207" [lst Options] 2]) 20 | (defalias 'options-bind #[(v f) "\303!\304\305\306\303\n\" \"!)\207" [v options f get-options list->options mapcat comp] 5]) 21 | #@57 Options monad - just window dressing on the list monad. 22 | (defvar options-monad (tbl! :m-bind 'options-bind :m-return #[(v) "\302\301JC!)\207" [v #1=#:--cl-v-- list->options] 2]) (#$ . 900)) 23 | (defalias 'fpush #[(x stack) " B\207" [x stack] 2]) 24 | (defalias 'fdrop #[(stack) "A\207" [stack] 1]) 25 | (defalias 'mfpush #[(mitems mstack) "\303\304\" \n\"\207" [options-monad mitems mstack m-lift-into2 fpush] 3]) 26 | (defalias 'mfdrop #[(mstack) "\302\303\" !\207" [options-monad mstack m-lift-into1 fdrop] 3]) 27 | (byte-code "\306\307\310\311\"!\210\312 \313\"\314 !\204\315\316!\210\317\320!\211\205\"\320K\321\216\320\322M\210\317\323!\211\2053\323K \324\216\323\325M\210\317\326!\211!\205F\326K\"\327\216\326\330M\210\317\331!\211#\205Y\331K$\332\216\331\333M\210\320\334\335\"\210.\336\337!\207" [options-monad current-monad m-zero #1=#:--cl-letf-bound-- #2=#:--cl-letf-save-- #3=#:--cl-letf-bound-- mfdrop mfpush (Options a b c) (Options nil (a) (a a)) tbl :m-zero monad\? error "Expected a monad in an mlet or similar form. \nA monad is a hash table with m-return and m-bind forms." fboundp m-bind ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#1# #2# m-bind fmakunbound] 2)) #[(v f) "\303\304\" \n\"\207" [current-monad v f tbl :m-bind] 3] m-return ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#3# #4=#:--cl-letf-save-- m-return fmakunbound] 2)) #[(v) "\302\303\" !\207" [current-monad v tbl :m-return] 3] >>= ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#5=#:--cl-letf-bound-- #6=#:--cl-letf-save-- >>= fmakunbound] 2)) #[(v f) "\303\304\" \n\"\207" [current-monad v f tbl :m-bind] 3] m-plus ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#7=#:--cl-letf-bound-- #8=#:--cl-letf-save-- m-plus fmakunbound] 2)) #[(mv1 mv2) "\303\304\" \n\"\207" [current-monad mv1 mv2 tbl :m-plus] 3] (Options 1 2 3) #[(&rest #9=#:G55818) "G\304 \305\"\2032\306\307!\211L\210\306\310!\211\nJ\311\234L\210\312\313\314\315\316\317\320 D\320\nD\321\257E\"*\2027\322\323 \314#)\207" [#9# #:G55819 #:--cl-lambda-seq-as-sym55824-- #:--cl-x-- arity-match (1 exactly) make-symbol "--lambda-seq-as-sym55824--" "--x--" 0 m-bind (Options 4 5 6) lambda (&rest --cl-rest--) apply #[(#10=#:G55856 #:G55857 &rest #11=#:G55845) "G\305 \306\"\203\302J\307\234\fJ\303J*D\202\310\311 \312#)\207" [#11# #:G55846 #:--cl-lambda-seq-as-sym55851-- #:--cl-y-- #10# arity-match (1 exactly) 0 error #12="Unable to find an arity match for %d args in fn %s." lambda] 4] quote --cl-rest-- error #12#] 10] get-options (Options a b c) #4# #5# #6# #7# #8#] 5) 28 | -------------------------------------------------------------------------------- /namer.el: -------------------------------------------------------------------------------- 1 | (require 'monads) 2 | 3 | (setq *go-button* nil) 4 | (setq *reset-button* nil) 5 | (defun namer-go (&optional button) 6 | (with-current-buffer "*namer*" 7 | (save-excursion 8 | (goto-char (point-min)) 9 | (let ((name-parts nil)) 10 | (while (= 0 (forward-line)) 11 | (let* ((line-contents (buffer-subline)) 12 | (split-string (split-string line-contents "/"))) 13 | (mlet monad-maybe^i 14 | ((_ (= (length split-string) 2)) 15 | (_ (not (string= (car split-string) ""))) 16 | (_ (not (string= (cadr split-string) ""))) 17 | (prop (car split-string)) 18 | (val (cadr split-string))) 19 | (setq name-parts (append name-parts (list prop val)))))) 20 | (put-string-on-kill-ring (join name-parts "=")) 21 | (goto-char (point-max)) 22 | (insertf "\n%s" (join name-parts "=")))))) 23 | 24 | (defun make-namer-buffer (&optional button) 25 | (interactive) 26 | (let ((buf (get-buffer-create "*namer*"))) 27 | (with-current-buffer buf 28 | (delete-region (point-min) 29 | (point-max)) 30 | (setq *go-button* 31 | (insert-button "Create Filename" 'action 32 | #'namer-go)) 33 | (insert "\n") 34 | (loop for i from 1 to 5 do 35 | (insertf "/\n")) 36 | (setq *reset-button* 37 | (insert-button 38 | "Reset" 39 | 'action 40 | #'make-namer-buffer))))) 41 | 42 | (make-namer-buffer) 43 | 44 | -------------------------------------------------------------------------------- /old.esl.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'defn) 3 | 4 | (setf *esl-stack* nil) 5 | (setf *esl-return-stack*) 6 | (setf *esl-code-stack*) 7 | 8 | (defn esl-push [item] 9 | ;(print *esl-stack*) 10 | (push item *esl-stack*)) 11 | (defn esl-pop [] 12 | ;(print *esl-stack*) 13 | (if ($ 0 = (length *esl-stack*)) 14 | (error "ESL: stack underflow %s" *esl-stack*)) 15 | (pop *esl-stack*)) 16 | (defn esl-dup [] 17 | (esl-push (car *esl-stack*))) 18 | (defn esl-swap [] 19 | (let ((a (esl-pop)) 20 | (b (esl-pop))) 21 | (esl-push a) 22 | (esl-push b))) 23 | 24 | 25 | (defun esl-mangle (name) 26 | (intern (format "__esl-word__%s" name))) 27 | 28 | (defun esl-unmangle (name) 29 | (intern (substring (format "%s" name) 0 12))) 30 | 31 | (defmacro* def-esl-word (name &body body) 32 | `(defun ,(esl-mangle name) () 33 | ,@body)) 34 | (defmacro* def-esl-binop (op) 35 | `(def-esl-word ,op (esl-swap) (esl-push (,op (esl-pop) (esl-pop))))) 36 | 37 | (defvar *esl-parsing-words* (tbl!)) 38 | 39 | (defmacro* def-esl-parsing-word (name &body body) 40 | (tbl! *esl-parsing-words* (esl-mangle name) t) 41 | `(def-esl-word ,name ,@body)) 42 | 43 | (defun parsing-word? (mangled-name) 44 | (member mangled-name (keyshash *esl-parsing-words*))) 45 | 46 | 47 | (def-esl-word + (esl-push (+ (esl-pop) (esl-pop)))) 48 | (def-esl-word - (esl-swap) (esl-push (- (esl-pop) (esl-pop)))) 49 | (loop for op in '( * / mod cons < > <= >=) do 50 | (eval `(def-esl-binop ,op))) 51 | (def-esl-word and (esl-swap) (let ((a (esl-pop)) (b (esl-pop))) (and a b))) 52 | (def-esl-word or (esl-swap) (let ((a (esl-pop)) (b (esl-pop))) (or a b))) 53 | (def-esl-word print (print (esl-pop))) 54 | (def-esl-word drop-all (setf *esl-stack* nil)) 55 | 56 | (setf *esl-called-from-hard-compiled* nil) 57 | (def-esl-word call 58 | (let ((qtn (esl-pop))) 59 | (if (functionp qtn) (funcall qtn) 60 | (progn 61 | (if *esl-called-from-hard-compiled* 62 | (esl-eval-compiled qtn) 63 | (progn 64 | (if *esl-code-stack* 65 | (push *esl-code-stack* *esl-return-stack*)) 66 | (setf *esl-code-stack* qtn))))))) 67 | 68 | (def-esl-word over (esl-push (cadr *esl-stack*))) 69 | (def-esl-word dip (let ((qtn (esl-pop)) 70 | (hold (esl-pop))) 71 | (esl-push qtn) 72 | (esl-eval-compiled '(__esl-word__call)) 73 | (esl-push hold))) 74 | (def-esl-word curry (let ((qtn (esl-pop)) 75 | (it (esl-pop))) 76 | (esl-push `((lambda () (esl-push ',it)) 77 | ,@qtn)))) 78 | (def-esl-word = (esl-push (= (esl-pop) (esl-pop)))) 79 | (def-esl-word not (esl-push (not (esl-pop)))) 80 | (def-esl-word if (let ((fb (esl-pop)) 81 | (tb (esl-pop)) 82 | (predval (esl-pop))) 83 | (if predval 84 | (esl-push tb) 85 | (esl-push fb)) 86 | (push (esl-mangle 'call) *esl-code-stack* ) 87 | )) 88 | 89 | (def-esl-word t (esl-push t)) 90 | (def-esl-word f (esl-push nil)) 91 | (def-esl-word quot>word (let ((name (esl-pop)) 92 | (qtn (esl-pop))) 93 | (eval `(def-esl-word ,name 94 | (push ',qtn *esl-return-stack*))))) 95 | 96 | (def-esl-word dup (esl-dup)) 97 | (def-esl-word drop (esl-pop)) 98 | (def-esl-word call-emacs-push 99 | (let ((emacs-fn (esl-pop)) 100 | (nargs (esl-pop))) 101 | (esl-push (apply emacs-fn (reverse (loop for i from 1 to nargs collect (esl-pop)))))) ) 102 | 103 | (def-esl-parsing-word : 104 | (let ((split (split-list-drop *esl-stack* 105 | (lambda (v) (eq v 'end-word:))))) 106 | (if split 107 | (dlet_ [[qtn rest] split] 108 | (setf *esl-stack* rest) 109 | (esl-push 'quot>word) 110 | (esl-push (list 'quote (car qtn))) 111 | (esl-push (cdr qtn))) 112 | (error "Could not find terminating end-word: for %s" (car *esl-stack*))))) 113 | 114 | (defn_ quotedp [it] 115 | (and (listp it) 116 | (eq 'quote (car it)))) 117 | 118 | (defn_ esl-compile [esl-code] 119 | (let ((*esl-stack* esl-code)) 120 | (loop with output = nil 121 | while *esl-stack* 122 | do 123 | (let ((part (esl-pop))) 124 | (cond 125 | 126 | ((listp part) 127 | (push (if (quotedp part) 128 | (eval `(function (lambda () (esl-push ,part)))) 129 | (eval `(function (lambda () (esl-push (quote ,(esl-compile part))))))) output)) 130 | ((symbolp part) 131 | (cond ((parsing-word? (esl-mangle part)) 132 | (funcall (esl-mangle part))) 133 | (t 134 | (push (esl-mangle part) output)))) 135 | ((or 136 | (numberp part) 137 | (stringp part)) 138 | (push (eval `(function (lambda () (esl-push ,part)))) output)))) 139 | finally (return (reverse output))))) 140 | 141 | (defun esl-next-part () 142 | (cond (*esl-code-stack* 143 | (pop *esl-code-stack*)) 144 | (*esl-return-stack* 145 | (setf *esl-code-stack* (pop *esl-return-stack*)) 146 | (pop *esl-code-stack*)) 147 | (t 148 | (error "Tried to get next part, but both the code stack and the return stack are empty - this should not happen.")))) 149 | 150 | 151 | (defun esl-eval-compiled (ccode) 152 | (if (functionp ccode) 153 | (let ((*esl-called-from-hard-compiled* t)) 154 | (functionp ccode)) 155 | (let ((*esl-code-stack* ccode) 156 | (*esl-called-from-hard-compiled* nil)) 157 | (loop while 158 | (or *esl-return-stack* 159 | *esl-code-stack*) 160 | do 161 | (let ((part (esl-next-part))) 162 | (funcall part)))))) 163 | 164 | (defmacro* esl-do (&body body) 165 | `(esl-eval-compiled (esl-compile ',body))) 166 | 167 | (defmacro* esl-dop (&body body) 168 | `(progn (esl-do ,@body) 169 | (esl-print-state) 170 | nil)) 171 | 172 | (defun esl-print-state () 173 | (let ((stack (loop with o = "" for s in (reverse *esl-stack*) do 174 | (setf o (concat o (format "\n %s" s))) 175 | finally (return o)))) 176 | (print (format "------------------\nesl-stack:\n- %s\n -----------------" stack)))) 177 | 178 | (dont-do 179 | (esl-dop drop-all 1 (1 +) curry call)) 180 | 181 | 182 | 183 | (esl-dop drop-all 184 | : when nil if end-word:) 185 | 186 | (esl-dop drop-all 110 t ( 1 + ) when ) 187 | 188 | (esl-dop : keep over (call) dip end-word: 189 | : loop (call) keep (loop) curry when end-word: 190 | : incr 1 + end-word:) 191 | 192 | (esl-compile '(nil)) 193 | (esl-do drop-all 5 5 * print ) 194 | 195 | 196 | 197 | 198 | -------------------------------------------------------------------------------- /old.loel.el: -------------------------------------------------------------------------------- 1 | (defvar *var-tag-table* 2 | (make-hash-table :weakness 'key-and-value) 3 | "var-tag-table is a weak table which helps identifty loel variables.") 4 | 5 | (defun* new-var-tag (var-sym) 6 | (let-if tag (gethash var-sym *var-tag-table*) tag 7 | (let ((tag (gensym ""))) 8 | (puthash var-sym tag *var-tag-table*) 9 | tag))) 10 | 11 | (defun tag-in-table? (sym tag) 12 | (eq (gethash sym *var-tag-table* nil) 13 | tag)) 14 | 15 | (defun f-var (sym) 16 | (vector '--var (new-var-tag sym) sym)) 17 | 18 | (defun var-tag (var) 19 | (elt var 1)) 20 | 21 | (defun var? (o) 22 | (and (vectorp o) 23 | (= (length o) 3) 24 | (eq (elt o 0) '--var) 25 | (tag-in-table? (var-sym o) (var-tag o)))) 26 | 27 | (defun var-sym (var) 28 | (elt var 2)) 29 | 30 | (defvar *symbol-counter* 0) 31 | (defun new-symbol () 32 | (prog1 (internf "_%d" *symbol-counter*) 33 | (setq *symbol-counter* (+ 1 *symbol-counter*)))) 34 | 35 | (defmacro* var (&optional (symbol (new-symbol))) 36 | (if (not (symbolp symbol)) 37 | (error "Var must be initialized with a symbol.") 38 | `(f-var ',symbol))) 39 | 40 | (example 41 | ; vars are specially tagged vectors which are distinct from any other 42 | ; vector except that vars with the same symbol name are structurally 43 | ; identical. 44 | 45 | (eq (var x) (var x)) 46 | (equal (var x) (var x)) 47 | ; this appears to be the implied semantics of The Reasoned Schemer 48 | ; with the additional proviso that one can handle arbitrarily similar 49 | ; vector structures as long as they haven't been produced with a call 50 | ; to f-var. 51 | 52 | (var? (var x)) ; detected as a var 53 | (var? (vector '--var 'sham-tag 'x)) ; similar vector structures are 54 | ; rejected. this allows the use 55 | ; of vectors as things in the loel 56 | ; sub-language. 57 | ) 58 | 59 | (defun rhs (assoc) (cdr assoc)) 60 | (defun lhs (assoc) (car assoc)) 61 | 62 | (recur-defun* walk-step (var sub) 63 | (cond 64 | ((empty? sub) nil) 65 | (t 66 | (if (eq (var-sym var) 67 | (var-sym (car (car sub)))) 68 | (car sub) 69 | (recur var (cdr sub)))))) 70 | 71 | (recur-defun* walk (var sub) 72 | (cond 73 | ((var? var) 74 | (let ((a (walk-step var sub))) 75 | (cond 76 | (a (recur (rhs a) sub)) 77 | (t var)))) 78 | (t var))) 79 | 80 | (recur-defun* walk* (var sub) 81 | (let ((v (walk var sub))) 82 | (cond 83 | ((var? v) v) 84 | ((pair? v) 85 | (cons 86 | (walk* (car v) sub) 87 | (walk* (cdr v) sub))) 88 | (t v)))) 89 | 90 | 91 | (defun ext-s (lhs rhs sub) 92 | (cons (cons lhs rhs) sub)) 93 | 94 | (defun pair? (o) 95 | (if o (listp o) o)) 96 | 97 | (example 98 | 99 | 100 | ; 101 | (walk (var x) (substitution (var x) 'b)) 102 | (walk* (var v) (substitution (var x) 'b 103 | (var v) (var w) 104 | (var w) (list (var x) 'c)))) 105 | 106 | (defun reify-name (n) 107 | (internf "_%d" n)) 108 | 109 | (defun size-s (n) 110 | (length s)) 111 | 112 | (defun* reify-s (v &optional (s nil)) 113 | (let ((v (walk v s))) 114 | (cond 115 | ((var? v) 116 | (ext-s v (reify-name (size-s s)) s)) 117 | ((pair? v) 118 | (reify-s (cdr v) 119 | (reify-s (car v) s))) 120 | (t s)))) 121 | 122 | (example 123 | 124 | (pp (let* ((s (substitution (var x) (var y) 125 | (var v) (var x) 126 | (var y) (var q))) 127 | (wv (walk (var v) s))) 128 | (reify-s wv))) 129 | 130 | ) 131 | 132 | (recur-defun* unify (v w sub) 133 | (cond 134 | ((eq v w) sub) 135 | ((var? v) (ext-s v w sub)) 136 | ((var? w) (ext-s w v sub)) 137 | ((and (pair? v) 138 | (pair? w)) 139 | (let ((u (unify 140 | (lhs v) 141 | (lhs w) sub))) 142 | (cond 143 | (u (recur (rhs v) (rhs w) u)) 144 | (t nil)))) 145 | ((equal v w) sub) 146 | (t nil))) 147 | 148 | (defmacro substitution (&rest pairs) 149 | `(list ,@(loop for pair in (bunch-list pairs) collect 150 | `(cons ,(car pair) ,(cadr pair))))) 151 | 152 | (unify (var v) (var x) (substitution (var v) 10 (var z) (var x))) -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:nil 4 | (:use #:cl)) 5 | 6 | -------------------------------------------------------------------------------- /parse-lambda-list.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'multi-methods) 3 | (provide 'parse-lambda-list) 4 | 5 | (defvar *default-parse-state* 6 | (alist>> :state :normal) "Initial state for lambda-list parsing.") 7 | 8 | (defun state-changer-p (possible-new-state) 9 | "Detects whether a token indicates a state change." 10 | (cond 11 | ((eq possible-new-state '&rest) :rest) 12 | ((eq possible-new-state '&optional) :optional) 13 | ((eq possible-new-state '&key) :key) 14 | (t nil))) 15 | 16 | (defun state-changer-p-with-checking (possible-new-state old-state) 17 | "Detects a state change but also makes sure that the change is valid for a lambda list. Any state 18 | may follow after normal arguments, but only keywords can follow after optional arguments." 19 | (let-if new-state (state-changer-p possible-new-state) 20 | (let ((pair (list old-state new-state))) 21 | (cond 22 | ((equal '(:normal :rest) pair) new-state) 23 | ((equal '(:optional :rest) pair) new-state) 24 | ((equal '(:normal :key) pair) new-state) 25 | ((equal '(:normal :optional) pair) new-state) 26 | ((equal '(:optional :key) pair) new-state) 27 | (t (error "Malformed lambda-list")))) 28 | nil)) 29 | 30 | (defun lambda-list-reducer (item acc) 31 | "The reducing function for parsing a lambda list by folding. Each step detects a state change or adds a 32 | token to the appropriate key in the accumulation alist." 33 | (let-alist ((state :state)) acc 34 | (let-if new-state (state-changer-p-with-checking item state) 35 | (alist>> acc :state new-state 36 | state (reverse (alist acc state))) 37 | (alist-cons acc 38 | state item)))) 39 | 40 | (defun* parse-lambda-list (lambda-list &key (extended t)) 41 | "Parses a (common-lisp-like) lambda list using a fold and a LAMBDA-LIST-REDUCER. Checks for malformed 42 | argument lists. Returns an association-list for the :normal, :key, :optional and :rest parts of the list." 43 | (reverse (alist-conjugate (dissoc (foldl #'lambda-list-reducer *default-parse-state* lambda-list) :state) 44 | :rest 45 | #'car nil))) 46 | 47 | (defun lambda-list-sub-form-get-name (sub-form) 48 | "Returns the symbol part of a lambda-list sub form: (x 10) or (x) -> x, but y -> y." 49 | (if (listp sub-form) (car sub-form) 50 | sub-form)) 51 | 52 | (defun lambda-list-names-in-order (lambda-list) 53 | "Return a list of the symbols in lambda-list, in the order they were encountered." 54 | (loop for item in (parse-lambda-list lambda-list) append 55 | (if item 56 | (case (car item) 57 | ((:rest) (if (cadr item) (list (cadr item)) nil)) 58 | (otherwise (mapcar #'lambda-list-sub-form-get-name (cadr item)))) 59 | nil))) 60 | 61 | (defun lambda-list-names-in-order-explicit-rest-list (lambda-list) 62 | "Return a list of the symbols in lambda-list, in the order they were encountered. 63 | In this version of the function, the rest form is enclosed in a list, for subsequent macro magic." 64 | (loop for item in (parse-lambda-list lambda-list) append 65 | (if item 66 | (case (car item) 67 | ((:rest) (if (cadr item) (list `(list ,(cadr item))) nil)) 68 | (otherwise (mapcar #'lambda-list-sub-form-get-name (cadr item)))) 69 | nil))) 70 | 71 | 72 | 73 | (dont-do 74 | 75 | ;example 76 | (defun* tttt (a b c &optional (x 10) (y 11) &key (z 13)) (list a b c x y z)) 77 | (tttt 1 2 3 4 'y :z 11) 78 | 79 | (cl-prettyprint (parse-lambda-list '(a b c &optional (x 10) (y 11) &key (z 13)))) 80 | ((:rest nil) 81 | (:key ((z 13))) 82 | (:optional ((x 10) (y 11))) 83 | (:normal (a b c))) 84 | 85 | 86 | 87 | ) 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /parse-lambda-list.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:49 2011 3 | ;;; from file /home/toups/elisp/utils/parse-lambda-list.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\210\303\304!\207" [require utils multi-methods provide parse-lambda-list] 2) 17 | #@40 Initial state for lambda-list parsing. 18 | (defvar *default-parse-state* (alist>> :state :normal) (#$ . 625)) 19 | #@51 Detects whether a token indicates a state change. 20 | (defalias 'state-changer-p #[(possible-new-state) "\301=\203\302\207\303=\203\304\207\305=\203\306\207\307\207" [possible-new-state &rest :rest &optional :optional &key :key nil] 2 (#$ . 737)]) 21 | #@190 Detects a state change but also makes sure that the change is valid for a lambda list. Any state 22 | may follow after normal arguments, but only keywords can follow after optional arguments. 23 | (defalias 'state-changer-p-with-checking #[(possible-new-state old-state) "\304!\211\205B\n D\211\305\232\203 \202A \306\232\203 \202A \307\232\203* \202A \310\232\2034 \202A \311\232\203> \202A\312\313!))\207" [possible-new-state new-state old-state pair state-changer-p (:normal :rest) (:optional :rest) (:normal :key) (:normal :optional) (:optional :key) error "Malformed lambda-list"] 3 (#$ . 997)]) 24 | #@161 The reducing function for parsing a lambda list by folding. Each step detects a state change or adds a 25 | token to the appropriate key in the accumulation alist. 26 | (defalias 'lambda-list-reducer #[(item acc) "\305 \306\"\307 \n\"\211\203\310\306\f\n\311\305\n\"!%\202$\312\n #+\207" [acc #1=#:table-58604 state item new-state alist :state state-changer-p-with-checking alist>> reverse alist-cons] 10 (#$ . 1613)]) 27 | #@246 Parses a (common-lisp-like) lambda list using a fold and a LAMBDA-LIST-REDUCER. Checks for malformed 28 | argument lists. Returns an association-list for the :normal, :key, :optional and :rest parts of the list. 29 | 30 | (fn LAMBDA-LIST &key (EXTENDED t)) 31 | (defalias 'parse-lambda-list #[(lambda-list &rest #1=#:--cl-rest--) "\305>\206\306A@\n\2036\n@\307>\203\nAA\211\202 \310>A@\203-\311\211\202 \312\313\n@\"\210\202\f)\314\315\316\317\320 \f#\321\"\322\323\311$!)\207" [#1# extended #2=#:--cl-keys-- *default-parse-state* lambda-list :extended (nil t) (:extended :allow-other-keys) :allow-other-keys nil error "Keyword argument %s not one of (:extended)" reverse alist-conjugate dissoc foldl lambda-list-reducer :state :rest car] 8 (#$ . 2040)]) 32 | #@84 Returns the symbol part of a lambda-list sub form: (x 10) or (x) -> x, but y -> y. 33 | (defalias 'lambda-list-sub-form-get-name #[(sub-form) "<\203@\207\207" [sub-form] 1 (#$ . 2800)]) 34 | #@82 Return a list of the symbols in lambda-list, in the order they were encountered. 35 | (defalias 'lambda-list-names-in-order #[(lambda-list) "\305!\306\211 :\203D @\307\n\2059\310\n@\311\"\2030\n\211A@)\2059\n\211A@)C\2029\312\313\n\211A@)\"! \244 A\211\202 \237+\207" [lambda-list #1=#:--cl-var-- item #2=#:--cl-var-- x parse-lambda-list nil reverse memql (:rest) mapcar lambda-list-sub-form-get-name] 5 (#$ . 2992)]) 36 | #@180 Return a list of the symbols in lambda-list, in the order they were encountered. 37 | In this version of the function, the rest form is enclosed in a list, for subsequent macro magic. 38 | (defalias 'lambda-list-names-in-order-explicit-rest-list #[(lambda-list) "\305!\306\211 :\203F @\307\n\205;\310\n@\311\"\2032\n\211A@)\205;\312\n\211A@)DC\202;\313\314\n\211A@)\"! \244 A\211\202 \237+\207" [lambda-list #1=#:--cl-var-- item #2=#:--cl-var-- x parse-lambda-list nil reverse memql (:rest) list mapcar lambda-list-sub-form-get-name] 5 (#$ . 3429)]) 39 | -------------------------------------------------------------------------------- /parse-seq-binder.el: -------------------------------------------------------------------------------- 1 | ;; parse-seq-binder 2 | ;; parses a sequence binder for clojure-like binding 3 | ;; See defn.el 4 | 5 | (require 'cl) 6 | (require 'utils) 7 | 8 | (defvar currently-defining-defn 'lambda) 9 | ; defvar this so that we can satisfy the elisp compiler. 10 | 11 | (defun parse-and-check-seq-binder (binder) 12 | "Given a BINDER expression describing a SEQUENCE, check and parse the expression into a useful form. 13 | Returns a list of the form: 14 | ( BINDERS 15 | REST-EXPRESSION 16 | AS-SYM 17 | OR-FORM ) 18 | 19 | Binders constitutes the 'ordinary' variable binding expressions. 20 | REST-FORM is the symbol to associate with anything after an '&' 21 | token. AS-SYM is the symbol to bind the entire expression to. 22 | NIL signifies NONE. OR-FORM is the expression (if any) to 23 | destructuring if destructuring the input fails. 24 | " 25 | (let-tbl 26 | ((binders :binders) 27 | (as-sym :as-sym) 28 | (rest-form :rest-form) 29 | (or-form :or-form)) 30 | (foldl 31 | (lambda (it ac) 32 | (let-tbl 33 | ((i :i) 34 | (prev :prev) 35 | (state :state) 36 | (n-as :n-as) 37 | (n-or :n-or) 38 | (n-rest :n-rest) 39 | (as-sym :as-sym) 40 | (or-form :or-form) 41 | (rest-form :rest-form) 42 | (binders :binders)) ac 43 | (case state 44 | (:parsing-binders 45 | (parse-seq-binders it ac)) 46 | (:parsing-rest 47 | (tbl! ac 48 | :state :parsing-special-forms 49 | :rest-form it 50 | :prev it 51 | :i 1)) 52 | (:parsing-special-forms 53 | (parse-seq-special-forms it ac))))) 54 | (tbl! 55 | :i 0 56 | :state :parsing-binders 57 | :n-as 0 58 | :n-or 0 59 | :n-rest 0 60 | :rest-form nil 61 | :as-sym nil 62 | :or-form nil 63 | :binders '()) 64 | (vector->list binder)) 65 | (list binders rest-form as-sym or-form))) 66 | 67 | (defun parse-seq-special-forms (it ac) 68 | "Parsing function for the special forms part of a SEQ binding 69 | expression. Takes a table in AC representing the parser state, 70 | and returns an appropriately modified table. 71 | IT is the current token." 72 | (let-tbl 73 | ((i :i) 74 | (state :state) 75 | (n-as :n-as) 76 | (n-or :n-or) 77 | (as-sym :as-sym) 78 | (or-form :or-form) 79 | (binders :binders) 80 | (prev :prev)) ac 81 | (cond 82 | ((oddp i) 83 | (if (or 84 | (eq :as it) 85 | (eq :or it)) 86 | (let* ((count-key (case it (:as :n-as) (:or :n-or))) 87 | (n-special-form (+ 1 (tbl ac count-key)))) 88 | (if (> n-special-form 1) (error "More than one %s clause in table binder in %s." it currently-defining-defn)) 89 | (tbl! ac 90 | :prev it 91 | :i (+ i 1) 92 | count-key n-special-form)) 93 | (error "Unrecognized special form keyword %s in %s" it currently-defining-defn))) 94 | ((evenp i) 95 | (let ((spec-key (case prev (:as :as-sym) (:or :or-form)))) 96 | (case prev 97 | (:as 98 | (if (symbolp it) 99 | (tbl! ac 100 | :i (+ i 1) 101 | :prev it 102 | spec-key it) 103 | (error "As forms must be symbols. Got %s instead in %s" it currently-defining-defn))) 104 | (:or 105 | (tbl! ac 106 | :i (+ i 1) 107 | :prev it 108 | spec-key it)))))))) 109 | 110 | (defun parse-seq-binders (it ac) 111 | "Parser for the sequential part of a SEQ binder. Takes a table 112 | representing the parser state in AC, and the current token IT, 113 | and returns an appropriately modified table." 114 | (let-tbl 115 | ((i :i) 116 | (prev :prev) 117 | (state :state) 118 | (n-as :n-as) 119 | (n-or :n-or) 120 | (n-rest :n-rest) 121 | (as-sym :as-sym) 122 | (or-form :or-form) 123 | (binders :binders)) ac 124 | (cond 125 | ((eq it '&) 126 | (let ((n-rest (+ n-rest 1))) 127 | (if (> n-rest 1) (error "More than one rest (&) clause detected parsing seq binder in %s." currently-defining-defn) 128 | (tbl! ac 129 | :state :parsing-rest 130 | :prev it 131 | :n-rest n-rest 132 | :i (+ i 1))))) 133 | ((keywordp it) 134 | (if (or (eq :as it) 135 | (eq :or it)) 136 | (let* ((count-key (case it (:as :n-as) (:or :n-or))) 137 | (n-special-form (+ 1 (tbl ac count-key)))) 138 | (if (> n-special-form 1) 139 | (error "More than one %s special-form in %s." it currently-defining-defn) 140 | (tbl! ac 141 | :i 2 142 | count-key n-special-form 143 | :state :parsing-special-forms 144 | :prev it))) 145 | (error "Unrecognized special form %s in %s " it currently-defining-defn))) 146 | (t 147 | (tbl! ac 148 | :binders (suffix binders it) 149 | :i (+ i 1) 150 | :prev it))))) 151 | 152 | 153 | 154 | (comment 155 | (parse-and-check-seq-binder [a b c & rest :as x :or (list 1 2 3)])) 156 | 157 | (provide 'parse-seq-binder) 158 | 159 | 160 | -------------------------------------------------------------------------------- /parse-sombers-lab-files.el: -------------------------------------------------------------------------------- 1 | (require 'better-monad-parse) 2 | (require 'scripting) 3 | 4 | (defparser =units 5 | (=>string 6 | "M" 7 | "uM" 8 | "nM" 9 | "L" 10 | "mL" 11 | "nL")) 12 | 13 | (defun char->trial (a) 14 | (if (stringp a) 15 | (char->trial (car (coerce a 'list))) 16 | (- a ?a))) 17 | 18 | (defparser =maybe-letter->trial 19 | (c <- (=>maybe =alpha-lower)) 20 | (m-return 21 | (if c (char->trial c) 22 | 0))) 23 | 24 | (defparser =_ (=>string "_")) 25 | 26 | (defparser =rotenone 27 | (=>stringi "rotenone" 28 | "rot")) 29 | 30 | (defparser =saline 31 | (=>stringi "saline" "sal")) 32 | 33 | (defparser =/ (=>string "/")) 34 | 35 | (defparser (=>pluck n) 36 | (in <- =input) 37 | (lexical-let ((new (pluck in n))) 38 | (parser 39 | (=>set-input new) 40 | (m-return new)))) 41 | 42 | (defparser =stim-desc 43 | (current <- =number) 44 | =_ 45 | (pulses <- =number) 46 | =_ 47 | (freq <- =number) 48 | (=>maybe =_) 49 | (trial <- =maybe-letter->trial) 50 | (m-return (alist>> :trial trial :current current :pulses pulses :freq freq :type "stim"))) 51 | 52 | 53 | (provide 'parse-sombers-lab-files) -------------------------------------------------------------------------------- /parse-table-binder.el: -------------------------------------------------------------------------------- 1 | ;; parse-table-binder 2 | ;; this code parses a table binder for clojure-like binding 3 | 4 | (require 'cl) 5 | (require 'utils) 6 | 7 | (setq currently-defining-defn 'lambda) 8 | 9 | (defun key->count-key (it) 10 | "Convert a token to the appropriate key to access its count in a table." 11 | (case it 12 | (:as :n-as) 13 | (:or :n-or) 14 | (:keys :n-keys))) 15 | 16 | (defun check-keys-form (form) 17 | "Check the :keys form in a TBL expressions." 18 | (and (vectorp form) 19 | (foldl 20 | (lambda (it ac) 21 | (and (not (keywordp it)) 22 | (symbolp it) 23 | ac)) 24 | t 25 | (vector->list form)))) 26 | 27 | (defun parse-tbl-special-forms (it ac) 28 | "Ad-hoc parser function which handles special form parsing for 29 | TBL binders. Takes a state in AC and the current token (IT) and 30 | returns the appropriate modified state." 31 | (let-tbl 32 | ((i :i) 33 | (state :state) 34 | (n-as :n-as) 35 | (n-or :n-or) 36 | (as-sym :as-sym) 37 | (or-form :or-form) 38 | (binders :binders) 39 | (prev :prev) 40 | (keys :keys)) ac 41 | (cond 42 | ((oddp i) 43 | (if (or 44 | (eq :keys it) 45 | (eq :as it) 46 | (eq :or it)) 47 | (let* ((count-key (key->count-key it)) 48 | (n-special-form (+ 1 (tbl ac count-key)))) 49 | (if (> n-special-form 1) (error "More than one %s clause in table binder in %s." it currently-defining-defn)) 50 | (tbl! ac 51 | :prev it 52 | :i (+ i 1) 53 | count-key n-special-form)) 54 | (error "Unrecognized special form keyword %s in %s" it currently-defining-defn))) 55 | ((evenp i) 56 | (let ((spec-key (case prev (:as :as-sym) (:or :or-form) (:keys :keys-seq)))) 57 | (case prev 58 | (:keys 59 | (if (check-keys-form it) 60 | (tbl! ac 61 | :i (+ i 1) 62 | :prev it 63 | spec-key it) 64 | (error ":keys must be followed by a vector of symbols, got %s instead in %s." it currently-defining-defn))) 65 | (:as 66 | (if (symbolp it) 67 | (tbl! ac 68 | :i (+ i 1) 69 | :prev it 70 | spec-key it) 71 | (error "As forms must be symbols. Got %s instead in %s" it currently-defining-defn))) 72 | (:or 73 | (tbl! ac 74 | :i (+ i 1) 75 | :prev it 76 | spec-key it)))))))) 77 | 78 | (defun parse-tbl-binders (it ac) 79 | "Parse the simple binders in a table binder. Takes a table 80 | representing parser state and a token, returning the 81 | appropriately modified state." 82 | (let-tbl 83 | ((i :i) 84 | (state :state) 85 | (n-as :n-as) 86 | (n-or :n-or) 87 | (as-sym :as-sym) 88 | (or-form :or-form) 89 | (binders :binders) 90 | (n-keys :n-keys) 91 | (keys-seq :keys-seq) 92 | (keys :keys)) ac 93 | (cond 94 | ((oddp i) 95 | (if (not (keywordp it)) 96 | (tbl! ac 97 | :i (+ i 1) 98 | :prev it 99 | :binders (suffix binders it)) 100 | (parse-tbl-special-forms 101 | it 102 | (tbl! ac 103 | :prev it 104 | :state :parsing-special-forms)))) 105 | ((evenp i) 106 | (tbl! ac 107 | :i (+ i 1) 108 | :prev it 109 | :keys (suffix keys it)))))) 110 | 111 | 112 | (defun parse-and-check-tbl-binder (binder) 113 | "Parse and check a BINDER expression which represents table 114 | destructuring. Works by conditionally folding over the tokens in 115 | BINDER. 116 | 117 | Return a list of the form 118 | 119 | (BINDERS KEYS AS-SYM OR-FORM KEYS-SEQ) 120 | 121 | BINDERS the symbols to bind 122 | KEYS the keys to bind them to, same order as BINDERS 123 | AS-SYM is the symbol to bind the entire table to, if provided. 124 | Otherwise it is NIL. 125 | OR-FORM is an expression which produces a table to destructuring when 126 | the input form fails to destructure properly. 127 | KEYS-SEQ the :keys portion of the binding form. 128 | 129 | " 130 | (let-tbl 131 | ((binders :binders) 132 | (keys :keys) 133 | (as-sym :as-sym) 134 | (or-form :or-form) 135 | (keys-seq :keys-seq)) 136 | (foldl 137 | (lambda (it ac) 138 | (let-tbl 139 | ((i :i) 140 | (state :state) 141 | (n-as :n-as) 142 | (n-or :n-or) 143 | (as-sym :as-sym) 144 | (or-form :or-form) 145 | (binders :binders) 146 | (keys :keys)) ac 147 | (case state 148 | (:parsing-binders 149 | (parse-tbl-binders it ac)) 150 | (:parsing-special-forms 151 | (parse-tbl-special-forms it ac)) 152 | (:init 153 | (if (eq it ::) 154 | (tbl! ac 155 | :state :parsing-binders 156 | :prev it 157 | :i (+ i 1)) 158 | (error "Hash-table binding forms must start with :: (%s)." currently-defining-defn)))))) 159 | (tbl! 160 | :i 0 161 | :state :init 162 | :n-as 0 163 | :n-or 0 164 | :n-keys 0 165 | :as-sym nil 166 | :or-form nil 167 | :keys-seq nil 168 | :prev nil 169 | :binders '() 170 | :keys '()) 171 | (vector->list binder)) 172 | (list binders keys as-sym or-form keys-seq))) 173 | 174 | (comment 175 | (parse-and-check-tbl-binder [:: a :a b :b c :c :as all :or something :keys [q r s]]) ) 176 | 177 | (provide 'parse-table-binder) 178 | 179 | 180 | -------------------------------------------------------------------------------- /parser-pres/index.el: -------------------------------------------------------------------------------- 1 | ;;; - Monadic Parser Combinators 2 | ;;; - xev 3 | ;;; - Atomic Parsers! 4 | ;;; - Combining Parsers 5 | ;;; - Meditation Upon Combination 6 | ;;; - Limitations of combine-parsers 7 | ;;; - Parser Bind 8 | ;;; - A bit more about bind. 9 | ;;; - Oh Dang it is the Lisp Slide 10 | ;;; - Demystifying the Macro Magic 11 | ;;; - Non-trivial Things 12 | ;;; - Useful Combinators 13 | ;;; - More Combinators 14 | ;;; - Example 15 | -------------------------------------------------------------------------------- /parser-pres/index.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:46 2011 3 | ;;; from file /home/toups/elisp/utils/parser-pres/index.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | -------------------------------------------------------------------------------- /parser-pres/page-1.el: -------------------------------------------------------------------------------- 1 | ;;; Monadic Parser Combinators 2 | ;;; A Ground up Introduction 3 | 4 | ;; The best way, I think, to understand how these things works is to 5 | ;; consider the question of what a monadic parser combinator is in 6 | ;; the following order: 7 | 8 | ;; 1) What is our representation of a parser? 9 | ;; 2) How do we combine them? 10 | ;; 3) How does this combination strategy form a monad? 11 | 12 | ;; Depending on your temperament, you might not even care about 3, 13 | ;; which is fine. The parser monad is useful without worrying too 14 | ;; hard about how monads work in general, but we will try to make 15 | ;; that clear in the course of the presentation. 16 | 17 | ;; N.B. : As with my parser-monad library, the general shape of this 18 | ;; talk owes a great deal to Drew Crampsie's SMUG Monadic Parser 19 | ;; Combinator Library for Common Lisp. 20 | ;; 21 | ;; I've simplified the parsers covered by this monad substantially for 22 | ;; the purposes of clarity and brevity, however. At the end of the 23 | ;; talk we'll touch briefly on the nature of those simplifications. 24 | 25 | (require 'el-pres) 26 | (rebuild-control-panel) 27 | 28 | ;;;Controls Home . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 29 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-10.el: -------------------------------------------------------------------------------- 1 | ;;; Demystifying the Macro Magic 2 | 3 | ;;; consider that : 4 | 5 | (mlet* seq-m 6 | ((x '(1 2 3)) 7 | (y '(4 5 6))) 8 | (+ x y)) 9 | 10 | (let* ((x 10) 11 | (y 11)) 12 | (+ x y)) 13 | 14 | (let* ((x 10) 15 | (y (+ x 1))) 16 | (+ x y)) 17 | 18 | ;;; expands to 19 | (comment 20 | (funcall 21 | (lambda (x) 22 | (funcall (lambda (y) (+ x y)) 11)) 23 | 10) 24 | ) 25 | 26 | ;;; or, provacatively: 27 | (comment 28 | (defun id-bind (v f) 29 | (funcall f v)) 30 | 31 | (id-bind 32 | 10 33 | (lambda (x) 34 | (id-bind 35 | 11 36 | (lambda (y) 37 | (+ x y)))))) 38 | 39 | ;;; or the semantic equivalent. 40 | ;;; 41 | ;;; parser-let*, then: 42 | 43 | (parser-let* 44 | ((a #'parse-a) 45 | (b #'parse-b)) 46 | (simple-parser-return 47 | (list a b))) 48 | 49 | ;;; expands to: 50 | 51 | (comment 52 | 53 | (parser-bind 54 | #'parse-a 55 | (lambda (a) 56 | (parser-bind 57 | #'parse-b 58 | (lambda (b) 59 | (simple-parser-return 60 | (list a b)))))) 61 | ) 62 | 63 | ;;; parser-let* is a generalization of let* which knows about how we 64 | ;;; want to combine parsers. Monads in general support extension of 65 | ;;; the idea of let*. That is, sequencing dependent computations. 66 | 67 | 68 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 69 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-11.el: -------------------------------------------------------------------------------- 1 | ;;; Non-trivial Things 2 | 3 | ;;; Ok, what kinds of fun things can we do with this parser monad 4 | ;;; business? 5 | 6 | ;;; Well, imagine you wish to match either: 7 | ;;; ab 8 | ;;; bc or 9 | ;;; ca 10 | 11 | ;;; We can do this with a single expression using our monadic parser 12 | ;;; combinators. Observe: 13 | 14 | 15 | (defun parse-a|b|c (input) 16 | (unless (empty? input) 17 | (string-case (str-head input) 18 | ("a" (pair :found-a (str-tail input))) 19 | ("b" (pair :found-b (str-tail input))) 20 | ("c" (pair :found-c (str-tail input)))))) 21 | 22 | (defun make-dependent-parser (last-result) 23 | (case last-result 24 | (:found-a #'parse-b) 25 | (:found-b #'parse-c) 26 | (:found-c #'parse-a))) 27 | 28 | (setq triangle-parser 29 | (parser-let* ((first-char #'parse-a|b|c) 30 | (second-char (make-dependent-parser first-char))) 31 | (simple-parser-return (cons first-char second-char)))) 32 | 33 | (funcall triangle-parser "ab") 34 | (funcall triangle-parser "bc") 35 | (funcall triangle-parser "ca") 36 | (funcall triangle-parser "aa") 37 | (funcall triangle-parser "cq") 38 | 39 | (find-file-other-frame "~/work/art/haskell-curry-says.png") 40 | 41 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 42 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-12.el: -------------------------------------------------------------------------------- 1 | ;;; Useful Combinators 2 | 3 | (defun -satisfies (pred) 4 | (lexical-let ((pred pred)) 5 | (parser-let* 6 | ((item #'anything)) 7 | (if (funcall pred item) 8 | (simple-parser-return item) 9 | #'nil-parser)))) 10 | 11 | (defun -manythings (n) 12 | (lexical-let ((n n)) 13 | (lambda (input) 14 | (if (< (length input) n) nil 15 | (pair 16 | (substring input 0 n) 17 | (substring input (min (length input) n))))))) 18 | 19 | (defun -matches (str) 20 | (lexical-let ((str str)) ; parser-let* implicitely 21 | ; constructs a function 22 | ; which requires str 23 | (parser-let* 24 | ((sub (-manythings (length str)))) 25 | (if (string= sub str) 26 | (simple-parser-return sub) 27 | #'nil-parser)))) 28 | 29 | ;;; because of the behavior of bind, we can't write the following 30 | ;;; function with parser-let*: 31 | 32 | (require 'recur) 33 | (defun -or (&rest parsers) 34 | (lexical-let ((parsers parsers)) 35 | (lambda (input) 36 | (unless (empty? input) 37 | (recur-let 38 | ((rem-parsers parsers)) 39 | (cond 40 | ((empty? rem-parsers) nil) 41 | (t 42 | (let ((r (funcall (car rem-parsers) input))) 43 | (if r r 44 | (recur (cdr rem-parsers))))))))))) 45 | 46 | ;;; example: 47 | 48 | (defun -cat-or-dog () 49 | (parser-let* ((res (-or (-matches "cat") 50 | (-matches "dog")))) 51 | (simple-parser-return res))) 52 | 53 | (funcall (-cat-or-dog) "ewe") 54 | (funcall (-cat-or-dog) "cat") 55 | (funcall (-cat-or-dog) "dog") 56 | 57 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 58 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-13.el: -------------------------------------------------------------------------------- 1 | ;;; More Combinators 2 | 3 | (defun -zero-or-more (parser) 4 | (lexical-let ((parser parser)) 5 | (lambda (input) 6 | (unless (empty? input) 7 | (recur-let ((result (funcall parser input)) 8 | (acc nil) 9 | (last-input input)) 10 | (if result 11 | (recur 12 | (funcall parser (parsed-leftover result)) 13 | (cons (parsed-value result) acc) 14 | (parsed-leftover result)) 15 | (pair (reverse acc) 16 | last-input))))))) 17 | 18 | (funcall (-zero-or-more 19 | (-matches "a")) 20 | "aaaab") 21 | (funcall (-zero-or-more 22 | (-matches "a")) 23 | "bbbb") 24 | 25 | (defun -one-or-more (parser) 26 | (lexical-let ((parser parser)) 27 | (parser-let* ((first parser) 28 | (rest (-zero-or-more parser))) 29 | (simple-parser-return (cons first rest))))) 30 | 31 | (funcall (-one-or-more 32 | (-matches "dog ")) 33 | "dog dog dog dog cat") 34 | 35 | (funcall (-one-or-more 36 | (-matches "dog ")) 37 | "cat dog dog dog cat") 38 | 39 | (defun -maybe (parser) 40 | (lexical-let ((parser parser)) 41 | (lambda (input) 42 | (unless (empty? input) 43 | (let ((r (funcall parser input))) 44 | (if r r 45 | (pair nil input))))))) 46 | 47 | (defun pempty? (input) 48 | "Check to see if you have hit the end of the input." 49 | (if (empty? input) (pair t input) 50 | (pair nil input))) 51 | 52 | (defun -list (parser) 53 | (lexical-let ((parser parser)) 54 | (parser-let* ((r parser)) 55 | (simple-parser-return 56 | (list r))))) 57 | 58 | (defun -not (parser) 59 | (lexical-let ((parser parser)) 60 | (lambda (input) 61 | (unless (empty? input) 62 | (let ((r (funcall parser input))) 63 | (if r nil 64 | (pair t input))))))) 65 | 66 | (defun -and2 (p1 p2) 67 | (lexical-let ((p1 p1) 68 | (p2 p2)) 69 | (parser-let* ((v1 p1) 70 | (v2 p2)) 71 | (simple-parser-return v2)))) 72 | 73 | (defun -and (&rest ps) 74 | (reduce #'-and2 ps)) 75 | 76 | (defun -and-list (&rest ps) 77 | (lexical-let ((ps ps)) 78 | (if (empty? ps) 79 | (lambda (input) 80 | (pair nil input)) 81 | (parser-let* 82 | ((v (car ps)) 83 | (rest (apply #'-and-list (cdr ps)))) 84 | (simple-parser-return (cons v rest)))))) 85 | 86 | (defun -n-of (n parser) 87 | (if (= n 1) (-list parser) 88 | (lexical-let ((n n) 89 | (parser parser)) 90 | (parser-let* 91 | ((head parser) 92 | (rest (-n-of (- n 1) parser))) 93 | (simple-parser-return (cons head rest)))))) 94 | 95 | (funcall (-n-of 3 (-matches "a")) "aaab") 96 | 97 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 98 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-14.el: -------------------------------------------------------------------------------- 1 | ;;; Example 2 | 3 | ;;; From RFC 1459, the IRC Chat Protocol Standards Docoument a Pseudo 4 | ;;; BNF description of an IRC Message. Lets write a parser for this. 5 | 6 | ;;; IRC MESSAGE: 7 | ;; ::= [':' ] 8 | ;; ::= | [ '!' ] [ '@' ] 9 | ;; ::= { } | 10 | ;; ::= ' ' { ' ' } 11 | ;; ::= [ ':' | ] 12 | ;; ::= 13 | ;; 16 | ;; ::= 17 | ;; 19 | ;; ::= CR LF 20 | 21 | 22 | 23 | ;;; We'll just assume that the line feed has been removed by a 24 | ;;; pre-parser that feeds us lines. 25 | 26 | (defun -trailing () 27 | (parser-let* ((trailing (-zero-or-more #'anything))) 28 | (simple-parser-return 29 | (list :trailing (reduce #'concat trailing))))) 30 | 31 | (defun -colon () 32 | (-matches ":")) 33 | 34 | (defun -colon-then-trailing () 35 | (parser-let* ((colon (-colon)) 36 | (trailing (-trailing))) 37 | (simple-parser-return trailing))) 38 | 39 | 40 | 41 | (setq tab (format "\t")) 42 | (defun -whitespaces () 43 | (-one-or-more (-or (-matches " ") 44 | (-matches tab)))) 45 | 46 | (defun -middle () 47 | (parser-let* 48 | ((not-colon (-not (-colon))) 49 | (contents (-zero-or-more (-not-whitespace)))) 50 | (simple-parser-return (list :middle (reduce #'concat contents))))) 51 | 52 | (defun -space-middle () 53 | (parser-let* 54 | ((_ (-whitespaces)) 55 | (middle (-middle))) 56 | (simple-parser-return middle))) 57 | 58 | (defun -params () 59 | (parser-let* 60 | ((params (-zero-or-more (-space-middle))) 61 | (_ (-whitespaces)) 62 | (trailing (-maybe (-colon-then-trailing)))) 63 | (simple-parser-return 64 | (cons (list :params 65 | (mapcar #'cadr params)) 66 | (if trailing (list trailing) 67 | nil))))) 68 | 69 | (defun -not-whitespace () 70 | (-satisfies 71 | (lambda (x) 72 | (and (not (string= x " ")) 73 | (not (string= x tab)))))) 74 | 75 | (defun -not-whitespaces () 76 | (-zero-or-more (-not-whitespace))) 77 | 78 | (lexical-let ((letters 79 | "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") 80 | (numbers "1234567890") 81 | (punctuation 82 | "~`!@#$%^&*()_+-={}[]|\\/<>,.:;'\"?")) 83 | (defun -letter () 84 | (-satisfies 85 | (lambda (x) 86 | (in (regexp-quote x) letters)))) 87 | (defun -number () 88 | (-satisfies 89 | (lambda (x) 90 | (in (regexp-quote x) numbers)))) 91 | (defun -punctuation () 92 | (-satisfies 93 | (lambda (x) 94 | (in (regexp-quote x) punctuation))))) 95 | 96 | (defun -command () 97 | (parser-let* 98 | ((command (-or 99 | (-one-or-more (-letter)) 100 | (-n-of 3 (-number))))) 101 | (simple-parser-return 102 | (list :command (reduce #'concat command))))) 103 | 104 | ;;; We are going to cheat for the sake of brevity, and define prefix as: 105 | 106 | (defun -prefix () 107 | (parser-let* ((contents (-zero-or-more (-not-whitespace)))) 108 | (simple-parser-return (list :prefix (reduce #'concat contents))))) 109 | 110 | ;;; Putting it all together: 111 | 112 | (defun -irc-message () 113 | (parser-let* 114 | ((_ (-colon)) 115 | (prefix (-prefix)) 116 | (_ (-whitespaces)) 117 | (command (-command)) 118 | (params&tail (-params))) 119 | (simple-parser-return 120 | (append (list prefix command) params&tail)))) 121 | 122 | 123 | (parsed-value (funcall (-irc-message) ":tod.com SEND a b c :rest")) 124 | 125 | ((:prefix "tod.com") 126 | (:command "SEND") 127 | (:params ("a" "b" "c")) 128 | (:trailing "rest")) 129 | 130 | 131 | ;;; WEEEEE 132 | 133 | 134 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 135 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-15.el: -------------------------------------------------------------------------------- 1 | ;;; Conclusions/Observations 2 | 3 | ;;; * Monadic Parser Combinators are about combining simple parsers 4 | ;;; * Like most monads, you need special syntax to make best use of 5 | ;;; them. 6 | 7 | ;;; * Since parsers are functions, they live in your language, can be 8 | ;;; tested individually, and can use the full power of the 9 | ;;; underlying language. Incremental development and testing makes 10 | ;;; writing parsers the same as writing any other program. 11 | 12 | ;;; Future Thoughts: 13 | 14 | ;;; * The parser monad isn't really anything special. It is actually 15 | ;;; the monad you get by transforming the maybe monad with the state 16 | ;;; monad transformer. 17 | 18 | ;;; * Ergo, (state-t sequence-m) is the non-deterministic parser monad 19 | ;;; in which individual parsers may return multiple results. 20 | 21 | ;;; * And (state-t stream-m) is the lazy, non-deterministic parser 22 | ;;; monad. Parsers in this monad return a stream (possibly 23 | ;;; infinite) of results. 24 | 25 | ;;; * What about _additional_ state? Consider the monad of functions: 26 | ;;; (lambda (&rest states) 27 | ;;; ;;; does things 28 | ;;; (pair a-result states)) 29 | ;;; 30 | ;;; By packing a stack or two into states one could parse with precedence. 31 | 32 | available here: 33 | 34 | https://github.com/VincentToups/emacs-utils 35 | 36 | 37 | ;;;Controls Home <<< . 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 38 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-2.el: -------------------------------------------------------------------------------- 1 | ;;; Parsers 2 | 3 | ;;; The whole point here is to enable us to build complex parsers out 4 | ;;; of simple ones. 5 | ;;; 6 | ;;; A simple parser is a function which takes an input and returns either: 7 | ;;; * nil, if the parser doesn't see what it wants 8 | ;;; * or a pair ( produced-value . left-over-input ) 9 | 10 | ;;; eg: 11 | 12 | (defun str-head (str) 13 | (substring str 0 1)) 14 | (defun str-tail (str) 15 | (substring str 1)) 16 | (defun pair (a b) 17 | (cons a b)) 18 | (defun parsed-value (pair) 19 | (car pair)) 20 | (defun parsed-leftover (pair) 21 | (cdr pair)) 22 | 23 | 24 | (defun parse-a (input) 25 | "A very simple parser - parses 'a' or nothing." 26 | (unless (empty? input) 27 | (if (string= "a" (str-head input)) 28 | (pair :found-a (str-tail input)) 29 | nil))) 30 | 31 | (parse-a "abracadabra") 32 | (parse-a "dogs of war") 33 | 34 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 35 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-2.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:46 2011 3 | ;;; from file /home/toups/elisp/utils/parser-pres/page-2.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (defalias 'str-head #[(str) "\301\302O\207" [str 0 1] 3]) 17 | (defalias 'str-tail #[(str) "\301\302O\207" [str 1 nil] 3]) 18 | (defalias 'pair #[(a b) " B\207" [a b] 2]) 19 | (defalias 'parsed-value #[(pair) "@\207" [pair] 1]) 20 | (defalias 'parsed-leftover #[(pair) "A\207" [pair] 1]) 21 | #@47 A very simple parser - parses 'a' or nothing. 22 | (defalias 'parse-a #[(input) "\301!?\205\302!\303\230\205\304\305\306!\"\207" [input empty\? str-head "a" pair :found-a str-tail] 4 (#$ . 787)]) 23 | (byte-code "\300\301!\210\300\302!\207" [parse-a "abracadabra" "dogs of war"] 2) 24 | -------------------------------------------------------------------------------- /parser-pres/page-3.el: -------------------------------------------------------------------------------- 1 | ;;; Atomic Parsers! 2 | 3 | ;;; You could imagine a ton of "parse-_" style parsers, but turns out 4 | ;;; there are even simpler parsers: 5 | 6 | (defun anything (input) ; aka "item" 7 | (unless (empty? input) 8 | (pair (str-head input) (str-tail input)))) 9 | 10 | ;;; And one very important _parameterized_ parser: 11 | 12 | (defun simple-parser-return (val) 13 | (lexical-let ((val val)) 14 | (lambda (input) 15 | (pair val input)))) 16 | 17 | (defun nil-parser (input) 18 | nil) 19 | 20 | 21 | ;;; This takes a value and returns a parser which "returns" that 22 | ;;; value, without changing the input. If you wanted to insert a 23 | ;;; value into your parsers for some reason, this is the function 24 | ;;; you'd use. 25 | ;;; 26 | ;;; It, too, will be of importance later. 27 | 28 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 29 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-4.el: -------------------------------------------------------------------------------- 1 | ;;; Combining Parsers 2 | 3 | ;;; Our goal is to make writing parsers as easy as writing programs. 4 | ;;; We program by combining simple functions. How do we combine 5 | ;;; simple parsers? 6 | 7 | (defun parse-b (input) 8 | (unless (empty? input) 9 | (if (string= (str-head input) "b") 10 | (pair :found-b (str-tail input))))) 11 | 12 | (defun parse-ab (input) 13 | (unless (empty? input) 14 | (let ((a-result (parse-a input))) 15 | (if a-result 16 | (let* ((a-val (parsed-value a-result)) 17 | (new-input (parsed-leftover a-result)) 18 | (b-result (parse-b new-input))) 19 | (if b-result 20 | (let* ((b-val (parsed-value b-result))) 21 | (pair (list a-val b-val) 22 | (parsed-leftover b-result))))))))) 23 | 24 | (parse-ab "abracadabra") 25 | (parse-ab "atrophy") 26 | (parse-ab "oboe") 27 | 28 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 29 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-5.el: -------------------------------------------------------------------------------- 1 | ;;; Meditation Upon Combination 2 | 3 | ;;; parse-ab was a mess. Can we factor out this complexity? 4 | 5 | (defun* combine-parsers (p1 p2 &optional (with #'list)) 6 | (lexical-let ((p1 p1) 7 | (p2 p2) 8 | (with with)) ; create lexical copies of p1 and p2 9 | ; since we are returning a lambda that 10 | ; which depends on them. 11 | (lambda (input) 12 | (unless (empty? input) 13 | (let ((r1 (funcall p1 input))) 14 | (if r1 15 | (let* ((v1 (parsed-value r1)) 16 | (leftover1 (parsed-leftover r1)) 17 | (r2 (funcall p2 leftover1))) 18 | (if r2 19 | (pair (funcall with v1 20 | (parsed-value r2)) 21 | (parsed-leftover r2)))))))))) 22 | 23 | ;;; COMBINE-PARSERS is a *combinator* or higher order function in the 24 | ;;; functional-programming sense. It is a function which operates on 25 | ;;; functions and returns a new function. 26 | 27 | (funcall (combine-parsers #'parse-a #'parse-b) "abraham a)") 28 | 29 | ;;; pretty sweet! 30 | 31 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 32 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-6.el: -------------------------------------------------------------------------------- 1 | ;;; Limitations of combine-parsers 2 | 3 | ;;; Combine-parsers works ok when we want to combine two parsers. We 4 | ;;; can even use the with argument to shoehorn more parsers together. 5 | 6 | (defun parse-c (input) 7 | (unless (empty? input) 8 | (if (string= (str-head input) "c") 9 | (pair :found-c (str-tail input)) 10 | nil))) 11 | 12 | (defun parse-a-b-c (input) 13 | (funcall 14 | (combine-parsers 15 | (combine-parsers #'parse-a #'parse-b) 16 | #'parse-c #'suffix) 17 | input)) 18 | 19 | (parse-a-b-c "abcdef") 20 | 21 | ;;; But that is really pretty inconvenient. And if we want to combine 22 | ;;; parsers which depend on the results of previous parsings, 23 | ;;; "combine-parsers" won't cut it. 24 | 25 | ;;; The crux of the issue is that we are really interested in the 26 | ;;; VALUE our parsers return, when combining parsers. We need an 27 | ;;; interface to expose these values selectively. 28 | 29 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 30 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-7.el: -------------------------------------------------------------------------------- 1 | ;;; Parser Bind 2 | 3 | ;;; So, we'd like a function which extracts the parser _value_ and 4 | ;;; binds it to a variable inside an expression which generates 5 | ;;; another parser. That way we could use this function to construct 6 | ;;; nested, value-dependent parsers conveniently (or sort of 7 | ;;; conveniently). 8 | 9 | ;;; If this doesn't seem obvious, don't worry too much. Once we do 10 | ;;; some examples, the utility will be clear. 11 | 12 | ;;; Consider: 13 | 14 | (defun simple-parser-bind (parser parser-producer) 15 | (lexical-let ((parser parser) 16 | (parser-producer parser-producer)) 17 | (lambda (input) ; we return a new parser 18 | (unless (empty? input) 19 | (let* ((res (funcall parser input))) 20 | (if res 21 | (let ((new-parser (funcall parser-producer (parsed-value res)))) 22 | (funcall new-parser (parsed-leftover res))) 23 | nil)))))) 24 | 25 | ;;; In words: parser-bind takes 1 - a parser 2 - a function which 26 | ;;; takes a value and returns a NEW parser, which may *depend* on 27 | ;;; that value. 28 | ;;; It returns a parser itself. 29 | ;;; This returned parser: 30 | ;;; 1 - applies PARSER to its input, generating a value/leftover pair. 31 | ;;; 2 - extracts the VALUE part of that pair, and creates yet another 32 | ;;; parser by calling PARSER-PRODUCER on that value. 33 | ;;; 3 - finally, it applies this new parser to the leftovers from PARSER 34 | 35 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 36 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-8.el: -------------------------------------------------------------------------------- 1 | ;;; A bit more about bind. 2 | 3 | (find-file-other-frame "~/work/art/monadic-types-of-interest.png") 4 | (find-file-other-frame "~/work/art/bind.png") 5 | 6 | ;;; * Bind is kind of unintuitive. 7 | ;;; * However, it is more useful than "combine" because 8 | ;;; it facilitates sequencing. 9 | ;;; * bind's second argument is a lambda 10 | ;;; * a lambda is a delayed computation which depends on 11 | ;;; _unbound_ values. 12 | ;;; * bind _binds_ these values in an ordered way, facilitating 13 | ;;; the sequencing of computations which result in monadic 14 | ;;; values. 15 | 16 | ;;; In the parser monad: 17 | ;;; * each lambda is a "delayed computation" which results in a 18 | ;;; _new parser_ when it is called with the value produced 19 | ;;; by a previous parser. 20 | ;;; * bind combines the new parser with the old parser, 21 | ;;; handling the plumbing needed to connect them together. 22 | ;;; * this plumbing is 23 | ;;; - check for nil 24 | ;;; - wrap up everything in a containing parser. 25 | 26 | 27 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 28 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/page-8.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:46 2011 3 | ;;; from file /home/toups/elisp/utils/parser-pres/page-8.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\207" [find-file-other-frame "~/work/art/monadic-types-of-interest.png" "~/work/art/bind.png"] 2) 17 | -------------------------------------------------------------------------------- /parser-pres/page-9.el: -------------------------------------------------------------------------------- 1 | ;;; Oh Dang it is the Lisp Slide 2 | 3 | ;;; All this junk about bind will melt into the background once we 4 | ;;; have one nice piece of syntax. 5 | 6 | ;;; We are about to roll a parser-specific equivalent of Haskell's do 7 | ;;; notation. If you don't care about lisp, feel free to tune this 8 | ;;; out. 9 | 10 | (defmacro parser-let* (binding-forms &rest body) 11 | (if (empty? binding-forms) `(progn ,@body) 12 | (let* ((binding-form (car binding-forms)) 13 | (subsequent-binders (cdr binding-forms)) 14 | (symbol (car binding-form)) 15 | (expression (cadr binding-form))) 16 | `(simple-parser-bind ,expression 17 | (lex-lambda (,symbol) 18 | (parser-let* ,subsequent-binders ,@body)))))) 19 | 20 | ;;; (lex-lambda creates a lexical closure around its arguments, 21 | ;;; otherwise it is a simple lambda expression. 22 | 23 | (defun simple-parser-return (val) 24 | (lexical-let ((val val)) 25 | (lambda (input) 26 | (pair val input)))) 27 | 28 | (find-file-other-frame "~/work/art/monadic-return.png") 29 | 30 | (funcall (parser-let* 31 | ((a-res #'parse-a) 32 | (b-res #'parse-b) 33 | (c-res #'parse-c)) 34 | (simple-parser-return (list a-res b-res c-res))) 35 | "abcdef") 36 | 37 | ;;; ZING! 38 | 39 | ;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 40 | ;;; Index -------------------------------------------------------------------------------- /parser-pres/scratch.el: -------------------------------------------------------------------------------- 1 | (get-pages-at-or-above 2) 2 | (safe-get-pages) 3 | (sort-by-page-ascending (sh "ls page-*.el")) -------------------------------------------------------------------------------- /partial-symbol-levenstein.el: -------------------------------------------------------------------------------- 1 | (require 'levenshtein) 2 | (require 'functional) 3 | (require 'utils) 4 | 5 | (defun partial-levenshtein (s1 s2 delim &optional absent-identical-p) 6 | (let* ((parts1 (split-string s1 delim t)) 7 | (parts2 (split-string s2 delim t)) 8 | (sorted-by-len (sort* (list parts1 parts2) (decorate-all #'> #'length))) 9 | (parts1 (car sorted-by-len)) 10 | (parts2 (cadr sorted-by-len)) 11 | (n-parts-2 (length parts2)) 12 | (parts2 13 | (loop for i from 0 below (length parts1) 14 | collect 15 | (if (< i n-parts-2) (elt parts2 i) 16 | (if absent-identical-p (elt parts1 i) ""))))) 17 | (reduce #'+ (mapcar* #'levenshtein-distance parts1 parts2)))) 18 | 19 | (defun partial-symbol-levenshtein (s1 s2) 20 | (partial-levenshtein (format "%s" s1) (format "%s" s2) "-")) 21 | 22 | 23 | (substring (md5 "skype+ru5tyb!kes") 0 20)" 24 | " 25 | 26 | (+ 5 25 7)0 27 | 28 | -------------------------------------------------------------------------------- /pattern-macro.el: -------------------------------------------------------------------------------- 1 | (require 'monads) 2 | (require 'monad-parse) 3 | 4 | (lex-defun =symbol-or-lit (literals) 5 | (lexical-let ((literals literals)) 6 | (=or 7 | (lexical-mlet 8 | monad-parse 9 | ((s (=satisfies (par #'in literals #'eq)))) 10 | (m-return `(:literal ,s))) 11 | (lexical-mlet 12 | monad-parse 13 | ((s (=satisfies #'symbolp))) 14 | (m-return `(:symbol ,s)))))) 15 | 16 | (lex-defun =symbol-lit-or-sub (literals) 17 | (=or (=symbol-or-lit literals) 18 | (=sub-expression literals))) 19 | 20 | (defun =symbol () 21 | (=satisfies #'symbolp)) 22 | (defun =list () 23 | (=satisfies #'listp)) 24 | (lex-defun =sub-expression (literals) 25 | (lexical-mlet 26 | monad-parse 27 | ((form (=list))) 28 | (m-return 29 | `(:sub-expression 30 | ,(parse-sequence (=pattern literals) form))))) 31 | 32 | (defun =elipses () 33 | (=satisfies (par #'eq '...))) 34 | 35 | (lex-defun =and-more-terminator (literals) 36 | (lexical-mlet monad-parse 37 | ((expr (=symbol-lit-or-sub literals)) 38 | (elipses (=elipses))) 39 | (m-return `(:one-or-more ,expr)))) 40 | 41 | 42 | (lex-defun =non-terminator (literals) 43 | (=and (=not (=and-more-terminator literals)) 44 | (=symbol-lit-or-sub literals))) 45 | 46 | (cl-prettyprint (parse-sequence (zero-or-more (=non-terminator '(x y))) '(x a v (y b ...) z ...))) 47 | 48 | 49 | (lex-defun =pattern (literals) 50 | (lexical-mlet monad-parse 51 | ((parts (zero-or-more (=non-terminator literals))) 52 | (term (zero-or-one (=and-more-terminator literals)))) 53 | (if term 54 | (m-return (suffix parts term)) 55 | (m-return parts)))) 56 | 57 | 58 | (cl-prettyprint (parse-sequence (=pattern '(x q)) '(a b c (y q ...) x ...))) 59 | ((:symbol a) 60 | (:symbol b) 61 | (:symbol c) 62 | (:sub-expression ((:symbol y) (:one-or-more (:literal q)))) 63 | (:one-or-more (:literal x))) 64 | 65 | 66 | (defun =symbol-or-list () 67 | (=or (=symbol) (=list))) 68 | (defun =non-tail-element (literals) 69 | (=and (=not (=pattern-tail)) 70 | (=symbol-or-list))) 71 | 72 | (defun =pattern-tail () 73 | (lexical-mlet 74 | monad-parse 75 | ((head-pattern (=symbol-or-list)) 76 | (elipses (=elipses))) 77 | (m-return (list :one-or-more head-pattern)))) 78 | 79 | (defun =pattern () 80 | (lexical-mlet 81 | monad-parse 82 | ((body (zero-or-more (=non-tail-element))) 83 | (tail (zero-or-one (=pattern-tail)))) 84 | (m-return (append body tail)))) 85 | 86 | (parse-sequence #'=pattern (list 'a)) 87 | 88 | (parse-sequence (=pattern) '((a b c) c ...)) 89 | 90 | (lex-defun item->parser-function (literals item) 91 | (cond 92 | ((symbolp item) 93 | (if ($ item in literals) 94 | (lexical-mlet monad-parse ((_ (=satisfies (par #'eq item)))) 95 | (m-return (list (list item _)))) 96 | (lexical-mlet monad-parse 97 | ((thing (=satisfies (always t)))) 98 | (m-return 99 | (list (list item thing)))))))) 100 | 101 | (parse-sequence (item->parser-function '(x) 'x) '(x)) 102 | (setq p (parser-append (item->parser-function '(x) 'x) 103 | (item->parser-function '(x) 'y))) 104 | 105 | (parse-sequence p '(x :hat)) 106 | 107 | (with-monad-dyn monad-parse 108 | (parse-sequence p '(x :hat))) 109 | 110 | 111 | 112 | (lex-defun parser-append (p1 p2) 113 | (lexical-mlet monad-parse 114 | ((v1 p1) 115 | (v2 p2)) 116 | (m-return (append v1 v2)))) 117 | 118 | (with-monad-dyn monad-parse 119 | (m-chain 120 | (item->parser-function '(z) 'x) 121 | (item->parser-function '(x) 'x))) 122 | 123 | 124 | (defun pattern->parser (literals pattern) 125 | (with-monad-dyn monad-parse 126 | (m-chain (mapcar (pal #'item->parser-function literals) pattern)))) 127 | 128 | (parse-sequence (funcall (pattern->parser '(x) '(a b x c))) '(q r x b)) 129 | 130 | (with-monad-dyn monad-parse 131 | (parse-sequence (pattern->parser '(x y) '(a b x z)) '(10 11 'x 'hey))) 132 | 133 | 134 | (defmacro pattern-macro (literals &rest {pattern/expansion}) 135 | 136 | -------------------------------------------------------------------------------- /pattern-matching.el: -------------------------------------------------------------------------------- 1 | 2 | (provide 'pattern-matching) 3 | 4 | (do-patterns (list 1 2 3) 5 | (cons first rest) (list first rest)) -> (1 (2 3)) 6 | 7 | (let* ((val (list 1 2 3)) 8 | (cons-pattern-result (cons-pattern '(first rest) val))) 9 | (cond (cons-pattern-result (let ((first (elt cons-pattern-result 0)) 10 | (second (elt cons-pattern-result 1))) 11 | 12 | (defmacro do-patterns -------------------------------------------------------------------------------- /persistent-hash-tables.el: -------------------------------------------------------------------------------- 1 | (require 'ra-lists) 2 | (require 'recur) 3 | 4 | (defstruct ptbl buckets test) 5 | 6 | (defalias 'ptbl? #'ptbl-p) 7 | 8 | (defun* fresh-ptbl (&optional (n 107) (test #'equal)) 9 | "Create a fresh persistent hash table with N (107) bins and 10 | TEST for equality." 11 | (make-ptbl :buckets (ra:make-list n '()) 12 | :test test)) 13 | 14 | (defvar the-empty-ptbl (fresh-ptbl) "An empty EQUAL testing persistent hash table.") 15 | (defvar the-empty-ptbl-eq (fresh-ptbl 107 #'eq) "An empty EQ testing persistent hash table.") 16 | 17 | (defun ptbl-set-buckets (p b) 18 | "Set the BUCKETS part of a persistent table P to B." 19 | (make-ptbl :buckets b 20 | :test (ptbl-test p))) 21 | 22 | (defun ptbl-dip-buckets (p f) 23 | "Set the BUCKETS part of a persistent table P to (FUNCALL F B), 24 | where B is the old buckets." 25 | (make-ptbl :buckets (funcall f (ptbl-buckets p)) 26 | :test (ptbl-test p))) 27 | 28 | (defun ptbl-n-buckets (p) 29 | "Return the number of buckets in the table P." 30 | (ra:length (ptbl-buckets p))) 31 | 32 | (recur-defun* ptbl-add-to-bucket (bucket key val test &optional acc) 33 | "Add an association to BUCKET with KEY, VAL and KEY equality 34 | tested under TEST." 35 | (cond ((empty? bucket) (cons (cons key val) acc)) 36 | (t 37 | (let* ((slot (car bucket)) 38 | (ckey (car slot)) 39 | (bucket-rest (cdr bucket))) 40 | (if (funcall test key ckey) (cons (cons key val) (append bucket-rest acc)) 41 | (recur bucket-rest key val test (cons slot acc))))))) 42 | 43 | (recur-defun* ptbl-get-from-bucket (bucket key test) 44 | "Find an association to BUCKET with KEY. TEST defines key equality." 45 | (cond ((empty? bucket) nil) 46 | (t 47 | (let* ((slot (car bucket)) 48 | (ckey (car slot)) 49 | (val (cdr slot)) 50 | (bucket-rest (cdr bucket))) 51 | (if (funcall test key ckey) val 52 | (recur bucket-rest key test)))))) 53 | 54 | (defun bucket-keys (bucket) 55 | "Return all the keys in a BUCKET." 56 | (mapcar #'car bucket)) 57 | 58 | (defun bucket-values (bucket) 59 | "Return all the values in a BUCKET." 60 | (mapcar #'cdr bucket)) 61 | 62 | 63 | (defun ptbl-set (tbl key val) 64 | "Return a new persistent hash table which is like TBL except 65 | that KEY is associated with VAL." 66 | (let* ((h (sxhash key)) 67 | (ix (mod h (ptbl-n-buckets tbl))) 68 | (buckets (ptbl-buckets tbl)) 69 | (bucket (ra:list-ref buckets ix))) 70 | (ptbl-set-buckets tbl 71 | (ra:list-set buckets ix (ptbl-add-to-bucket bucket key val (ptbl-test tbl)))))) 72 | 73 | (defun {} (maybe-ptbl &rest args) 74 | "Construct or augment a PTBL with the KEY/VAL pairs in ARGS. 75 | If MAYBE-PTBL is not a PTBL, treat it as the first key and use an 76 | empty persistent table." 77 | (if (not (ptbl? maybe-ptbl)) (apply #'{} the-empty-ptbl (cons maybe-ptbl args)) 78 | (recur-let ((key/vals args) 79 | (ptbl maybe-ptbl)) 80 | (if (empty? key/vals) ptbl 81 | (let ((key (car key/vals)) 82 | (val (cadr key/vals)) 83 | (rest (cddr key/vals))) 84 | (recur rest 85 | (ptbl-set ptbl key val))))))) 86 | 87 | (defun ptbl-get (tbl key &optional or-value) 88 | "Retreive the association for KEY from the persistent hashtable 89 | TBL. Return OR-VALUE if no association exists, which defaults to 90 | NIL." 91 | (let* ((h (sxhash key)) 92 | (ix (mod h (ptbl-n-buckets tbl))) 93 | (buckets (ptbl-buckets tbl)) 94 | (bucket (ra:list-ref buckets ix)) 95 | (r (ptbl-get-from-bucket bucket key (ptbl-test tbl)))) 96 | (if r r or-value))) 97 | 98 | (defun ptbl-keys (tbl) 99 | "Return a list of all keys in the persistent hash table TBL. 100 | Order is unspecified." 101 | (recur-let ((buckets (ptbl-buckets tbl)) 102 | (keys '())) 103 | (cond 104 | ((ra:null? buckets) keys) 105 | (t (recur 106 | (ra:cdr buckets) 107 | (append (bucket-keys (ra:car buckets)) keys)))))) 108 | 109 | (defun ptbl-values (tbl) 110 | "Return a list of all values in the persistent hash table TBL. 111 | Order is unspecified." 112 | (recur-let ((buckets (ptbl-buckets tbl)) 113 | (vals '())) 114 | (cond 115 | ((ra:null? buckets) vals) 116 | (t (recur 117 | (ra:cdr buckets) 118 | (append (bucket-values (ra:car buckets)) vals)))))) 119 | 120 | (defun ptbl->alist (tbl) 121 | "Return an association list with the same assocations as TBL." 122 | (recur-let ((keys (ptbl-keys tbl)) 123 | (pairs '())) 124 | (if (empty? keys) 125 | pairs 126 | (recur (cdr keys) 127 | (cons (cons (car keys) 128 | (ptbl-get tbl (car keys))) pairs))))) 129 | 130 | (defun ptbl->ppstring (tbl) 131 | "Produce a nice string representation of the persistent hash table TBL." 132 | (recur-let ((keys (ptbl-keys tbl)) 133 | (str "({} ")) 134 | (if (empty? keys) 135 | str 136 | (recur (cdr keys) 137 | (concat str 138 | (format "%s%s %s%s%s" 139 | (if (or (symbolp (car keys)) 140 | (listp (car keys))) "'" "") 141 | (car keys) 142 | (if (or (symbolp (ptbl-get tbl (car keys))) 143 | (symbolp (ptbl-get tbl (car keys)))) "'" "") 144 | (ptbl-get tbl (car keys)) 145 | (if (empty? (cdr keys)) ")" " "))))))) 146 | 147 | (provide 'persistent-hash-tables) 148 | 149 | -------------------------------------------------------------------------------- /prolapse.el: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /prolapse.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:47 2011 3 | ;;; from file /home/toups/elisp/utils/prolapse.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | -------------------------------------------------------------------------------- /quantities.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'recur) 3 | 4 | (defstruct quantity value error units) 5 | (defstruct qunit name type conversions) 6 | 7 | (defvar *unit-types* '()) 8 | (defvar *units* '()) 9 | 10 | (defun find-unit-with-name (name) 11 | (recur-let 12 | ((lst *units*)) 13 | (cond 14 | ((empty? lst) nil) 15 | ((eq (qunit-name (car lst) 'name)) (car lst)) 16 | (t (recur (cdr lst)))))) 17 | 18 | (defmacro qunit (spec) 19 | (if (symbolp spec) `(find-unit-with-name ',spec) 20 | spec)) 21 | 22 | (defmacro declare-unit (unit-name type &rest conversions) 23 | `(progn 24 | (push 25 | (make-qunit :name ',unit-name :type ',type :conversions (list ,@conversions)) *units*) 26 | (setq *unit-types* 27 | (alist-cons *unit-types* ',type (qunit ',unit-name))))) 28 | 29 | (declare-unit 'grams 'mass) -------------------------------------------------------------------------------- /recur.md: -------------------------------------------------------------------------------- 1 | recur-defun and recur-let 2 | ------------------------- 3 | 4 | When I first encountered clojure's limited tail call optimization, in 5 | the form of "recur" forms inside functions and loops, I was a bit 6 | disappointed. Even though (obviously) I write most of my lisp code in 7 | hoary old emacs lisp, I think I lean towards the scheme side of things 8 | in a lot of respects, and I like writing functions recursively when 9 | possible. [Lots of people 10 | disagree](http://dorophone.blogspot.com/2009/04/python-tail-call-hullabu.html), 11 | but I find this is a clear, concise and error avoiding way of 12 | specifying lots of algorithms. I find loops, on the other hand, error 13 | prone and ugly for many kinds of tasks, although the Common Lisp Loop 14 | Macro is pretty nice for lots of simple cases. 15 | 16 | However, if you read the above blog post, you'll notice some nuance to 17 | my opinion which eventually made me warm to the `recur` form in 18 | clojure. Since the stack is a limited resource in most programming 19 | systems for reasons of optimization, and since tail calls don't grow 20 | the stack, and are therefore something like "meta-semantically" 21 | different than non-tail calls, I rather like that Clojure forces you 22 | to explicitly mark an attempted tail call, and barfs at you if you 23 | place it in a non-tail location. This seems like a good idea, even if 24 | you lose a bit of elegance in not using the name of the function 25 | itself to recur. Reflection on this theme eventually reveals that the 26 | real limitation of `recur` in Clojure is that it only allows 27 | self-recursion. A conforming scheme optimizes all tail calls, 28 | regardless of their location. In practice, lots of algorithms depend 29 | on self-recursion only (but see the Ackerman numbers for a standard 30 | counter example of a sort - they are usually computed with several 31 | mutually recursive functions), and since the JVM doesn't support 32 | complete tail call optimization, `recur` represents an elegant 33 | compromise between slow, trampoline based full optimization, and 34 | relying entirely on loops or other ad-hoc iteration techniques. 35 | 36 | I promise I am getting somewhere. 37 | 38 | [Once 39 | again](https://github.com/VincentToups/emacs-utils/blob/master/multi-methods.md) 40 | I am faced with a comparison between Clojure and Emacs Lisp, because 41 | both are Lisps which find themselves living in somewhat primitive 42 | run-times. Emacs Lisp is somewhat constrained by legacy 43 | considerations (although I don't rightly know why the EL engine 44 | doesn't optimize tail calls - if anyone does, please contact me) and 45 | frankly, somewhat outmoded design. Clojure, similarly saddled with 46 | the JVM, shows considerable insight and care in its design, providing 47 | modern, powerful features to a difficult environment. `Recur` is one 48 | such feature. 49 | 50 | I wanted to add this capability to Emacs Lisp because I kept running 51 | into places in other projects where I was writing big, gross loops 52 | where a recursive implementation would have been easier to write and 53 | read. Technically, I've already done this since I've ported all of 54 | Clojure's `defn` and `loop\let` destructuring bind forms into Elisp, 55 | and these forms provide for the use of the `recur` keyword without 56 | growing the stack. Read about those features 57 | [here](https://github.com/VincentToups/emacs-utils/blob/master/README.md). 58 | However, the "Clojure-like emacs" project was one of my first very 59 | large forays into Emacs Lisp and Programming Language Implementation, 60 | and even though I frequently use it, it is a little slow (unless one 61 | byte-compiles it) and frightening to use. The implementation is 62 | crufty and needs an overhaul. 63 | 64 | So I decided I'd re-implement the features I wanted in a more Emacs 65 | Lisp flavored way. This library provides those features in two forms. 66 | One is a `recur-let` form which allows recursive calls on a let's 67 | binding forms, similar to Scheme's `named-let` feature. The other is 68 | a `recur-defun*` form, which allows you to declare a function (with a 69 | common lisp-like lambda-list) which can `recur` to itself using the 70 | recur keyword. Neither forms grow the stack during their 71 | pseudo-recursion. It is quite possible to write infinite loops, for 72 | instance. 73 | 74 | Examples Are In Order 75 | --------------------- 76 | 77 | Here is an example of `recur-let` 78 | 79 | (require 'recur) 80 | (recur-let ((x 0)) 81 | (if (< x 10) (recur (+ x 1)) x)) 82 | 83 | This evaluates to 10. 84 | 85 | Here is an example of `recur-defun*` 86 | 87 | (recur-defun* my-prod (list &optional (acc 1)) 88 | (if list (recur (cdr list) (* acc (car list))) 89 | acc)) 90 | (my-prod (list 1 2 3 4)) 91 | 92 | The second form evaluates, as it should, to 24. (Thanks to Joseph Gay 93 | for the correction). 94 | 95 | Conclusions 96 | ----------- 97 | 98 | This implementation is much, much simpler than the implementation 99 | associated with `defn` and its kin from my clojure library. Although 100 | this is a very early version, I think the library is stable enough to 101 | use for real things. 102 | 103 | Most of the complexity here was not even related to the implementation 104 | of recursion itself, but with parsing lambda-lists, for which emacs 105 | seems to have no native functions. I am sure I could have used some 106 | piece of `cl.el` code, but a cursory search didn't reveal anything. 107 | 108 | Most of the code is commented. I hope someone out there finds this 109 | useful. If you are interested in code-walking macros, this might be a 110 | good example to get a sense for how they work and what they do. The 111 | critical part of this implementation is a codewalker which searches 112 | for `recur` and expands it appropriately or throws an error if we 113 | aren't in tail position. 114 | 115 | Thanks for reading! 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | -------------------------------------------------------------------------------- /scratch.el: -------------------------------------------------------------------------------- 1 | (require 'with-stack) 2 | (require 'stack-words) 3 | 4 | 5 | (||| 6 | word: seq-return 1>list end: 7 | word: seq-bind ; (list func) 8 | map 'append swap 2>apply end:) 9 | 10 | (|||p { {{ 1 2 3 4 }} 11 | { { 1 + } { 1 - } bi 2>list } 12 | { + 1>list } 13 | 14 | '(list-bind) 15 | do-monadically ) 16 | 17 | {{ 1 2 3 4 }} q1 bind 18 | with 19 | q1 { { { 1 + } { 1 - } bi 2>list } q2 bind } 20 | with 21 | q2 { + 1>list } 22 | 23 | 24 | (bind '(1 2 3 4) 25 | (lambda (x1) 26 | (bind (list (+ x1 1) (- x1 1)) 27 | (lambda (x2) 28 | (m-return (+ x1 x2)))))) 29 | 30 | (|||p '(1 2 3) '('(2 +) '(2 -) bi 2>list) seq-bind 31 | '('(1 +) '(1 -) bi 2>list) seq-bind) 32 | 33 | (|||p '(2 +) ) 34 | 35 | (|||p '(1 2 3 4) 4 '(+) curry map) 36 | 37 | (|||p '(list-bind) dup '(call) curry) 38 | 39 | (word: state-return ;( object -- qtn( stack -- {/ object stack /} )) 40 | 2>list) 41 | 42 | (||| 43 | word: Just? dup listp '(car 'Just eq) '(nil) if end: 44 | word: Just '(Just) swap suffix end: 45 | word: Just-val 1>cadr end: 46 | word: Error '(Error) swap suffix end: 47 | word: Error? dup listp '(car 'Error eq) '(nil) if end: 48 | word: error-return Just end: 49 | word: error-bind ;( v f -- mr ) 50 | swap dup Error? '() '(Just-val swap call) if end: 51 | word: safe-div dup 0 = '(drop "Divide by zero error." Error) '( / Just) if end: 52 | word: implicit-error-bind ;( v f -- mr ) 53 | swap dup Error? '() '(drop swap print-stack call) if end: 54 | ) 55 | 56 | (||| 30 Just '(3 safe-div) error-bind 57 | '( 10 + Just ) error-bind) 58 | 59 | (||| word: im-safe-div dup 0 = '(drop "Divide by zero." Error) '( / ) if end:) 60 | 61 | (||| 30 '(0 im-safe-div) implicit-error-bind) 62 | 63 | (||| 64 | word: extract-monad '(car) '(cadr) bi end: 65 | word: cons-twice cons cons end: 66 | word: fold-bind-into ;( seq bind-op -- seq ) 67 | '( swap cons _ swap cons ) fry 68 | nil swap foldl reverse end: 69 | 70 | word: fold-bind-into"ify-atoms ;( seq bind-op -- seq ) 71 | '( quote-list-if-not-quote-list swap cons _ swap cons ) fry 72 | nil swap foldl reverse end: 73 | 74 | word: monadically ;( initial qt-seq bind -- monadic-value ) 75 | fold-bind-into 76 | call end: 77 | 78 | word: monadically* ;( initial qt&atom-seq bind -- monadic-value ) 79 | thread-quote call end: 80 | 81 | word: tag ;( value tag -- tagged-value ) 82 | swap 2>list end: 83 | word: tagged-with? ;( value tag -- boolean ) 84 | swap dup listp '(car eq) '(drop drop nil) if end: 85 | word: untag ;(tagged-value -- value ) 86 | cadr end: 87 | 88 | word: Branches 'Branches tag end: 89 | word: Branches? 'Branches tagged-with? end: 90 | 91 | word: implicit-sequence-bind ;( v f -- mr ) 92 | swap dup Branches? print-stack 93 | '(untag swap seq-bind Branches) 94 | '(1>list swap seq-bind Branches) if 95 | end: 96 | 97 | 98 | ) 99 | 100 | (word: make-quotation '() curry 'quote swap 2>list) 101 | (word: cons-twice ;( item item lst ) 102 | '(cons) curry dip swons) 103 | (word: 2prefix ;( a b lst -- (a b @lst) 104 | prefix prefix ) 105 | 106 | (|||p 'a 'b '(c) 2prefix) 107 | 108 | (word: swons ;( list item ) 109 | swap cons ) 110 | (word: swons-twice ;( list item item ) 111 | 112 | (word: thread-quote-step ;( thread -- quot ) 113 | ;( lst item -- lst ) 114 | '( make-quotation swons _ swons ) fry) 115 | (word: thread-quote ;( lst thread -- threaded ) 116 | thread-quote-step nil swap foldl reverse ) 117 | 118 | (|||p 10 'x tag 'y tagged-with?) 119 | 120 | (|||p 0 'Branches tagged-with?) 121 | 122 | (|||p 10 1>list Branches '( '(14 12 2>list Branches) + ) implicit-sequence-bind monadically* ) 123 | (|||p 0 '(3 +) ''implicit-sequence-bind fold-bind-into"ify-atoms) 124 | 125 | (|||p 0 '( '(1 +) '(1 -) bi 2>list Branches ) ''implicit-sequence-bind monadically*) 126 | 127 | (word: quote-list-if-not-quote-list 128 | dup listp '() '(1>list 'quote swap 2>list) if) 129 | 130 | (|||p 'x list-if-not-list) 131 | 132 | (|||p 4 '( 0 safe-div ) ''implicit-error-bind monadically* ) 133 | 134 | (||| 10 error-return Just?) 135 | ) 136 | 137 | (|||p '(a b c '(d)) ''x fold-bind-into"ify-atoms) 138 | 139 | (||| 140 | word: mark-for-reification 141 | "unreification-marker" 1>gensym dup >r 142 | end: 143 | word: state-bind ;( mv f -- qtn( stack -- {/ result stack /} )) 144 | swap 145 | '( mark-for-reification 146 | swap push-list 147 | _ 148 | 149 | 150 | -------------------------------------------------------------------------------- /scratch.md: -------------------------------------------------------------------------------- 1 | (require 'monads) -------------------------------------------------------------------------------- /scripting.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'functional) 3 | (require 'with-stack) 4 | (require 'stack-words) 5 | 6 | (defun dircat (&rest args) 7 | (join (filter (/| (not (string= "" %1))) (flatten 8 | (mapcar 9 | (clambdar #'split-string "/") 10 | args))) "/")) 11 | 12 | 13 | 14 | 15 | (setq *file-info-alist* '(("%a" (:access-rights-in-octal (lambda (x) x))) 16 | ("%A" (:access-rights-in-human-readable-form (lambda (x) x))) 17 | ("%b" (:number-of-blocks-allocated-see-%b string-to-number)) 18 | ("%B" (:the-size-in-bytes-of-each-block-reported-by-%b string-to-number)) 19 | ("%d" (:device-number-in-decimal string-to-number)) 20 | ("%D" (:device-number-in-hex (lambda (x) x))) 21 | ("%f" (:raw-mode-in-hex (lambda (x) x))) 22 | ("%F" (:file-type (lambda (x) x))) 23 | ("%g" (:group-id-of-owner (lambda (x) x))) 24 | ("%G" (:group-name-of-owner (lambda (x) x))) 25 | ("%h" (:number-of-hard-links (lambda (x) x))) 26 | ("%i" (:inode-number (lambda (x) x))) 27 | ("%n" (:file-name (lambda (x) x))) 28 | ("%N" (:quoted-file-name-with-dereference-if-symbolic-link (lambda (x) x))) 29 | ("%o" (:i/o-block-size (lambda (x) x))) 30 | ("%s" (:total-size-in-bytes string-to-number)) 31 | ("%t" (:major-device-type-in-hex (lambda (x) x))) 32 | ("%T" (:minor-device-type-in-hex (lambda (x) x))) 33 | ("%u" (:user-id-of-owner (lambda (x) x))) 34 | ("%U" (:user-name-of-owner (lambda (x) x))) 35 | ("%x" (:time-of-last-access (lambda (x) x))) 36 | ("%X" (:time-of-last-access-as-seconds-since-epoch string-to-number)) 37 | ("%y" (:time-of-last-modification (lambda (x) x))) 38 | ("%Y" (:time-of-last-modification-as-seconds-since-epoch string-to-number)) 39 | ("%z" (:time-of-last-change (lambda (x) x))) 40 | ("%Z" (:time-of-last-change-as-seconds-since-epoch string-to-number)))) 41 | (setq *file-info-alist-keys* 42 | (mapcar (comp #'car #'cadr) *file-info-alist*)) 43 | 44 | 45 | (setq *simple-file-info* 46 | `(("%n" (:name (lambda (x) x))) 47 | ("%Y" (:last-change string-to-number)) 48 | ("%s" (:size string-to-number)))) 49 | 50 | (defun* file-info (file &optional (format-alist *simple-file-info*)) 51 | (let* ((format (concat "--format=\"" (join (mapcar #'car format-alist) " ") "\"")) 52 | (parts (split-string 53 | (car (shf "stat -t %s %s" format file)) " "))) 54 | (zip (mapcar (comp #'car #'cadr) format-alist) 55 | (mapcar* (lambda (part alist-part) 56 | (let ((f (cadr (cadr alist-part)))) 57 | (funcall f part))) 58 | parts format-alist)))) 59 | 60 | (defun file-size (file) 61 | (alist (file-info file '(("%s" (:size string-to-number)))) :size)) 62 | 63 | (defun file-loc (filename) 64 | (||| lisp-val: (split-string filename "/") reverse cdr reverse "/" 2>join)) 65 | 66 | (defun file-name (filename) 67 | (||| lisp-val: (split-string filename "/") reverse car)) 68 | 69 | (defun file-name-flatten-with (filename rep) 70 | (join (filter 71 | (lambda (x) (not (or (eq x nil) (string= x "") 72 | (string= x " ") (string= x ".") 73 | (string= x "..")))) 74 | (split-string filename "/") ) rep)) 75 | 76 | (defun* pluck (filename &optional (n-in 0)) 77 | (let* ((loc-parts (reverse (split-string (file-loc filename) "/"))) 78 | (name (file-name filename)) 79 | (partial-stem (reverse (ix: loc-parts (range n-in))))) 80 | (concat (apply #'dircat partial-stem) (if (> (length partial-stem) 0) "/" "") name))) 81 | 82 | (defun* clip (filename &optional (n-at 0)) 83 | (let* ((loc-parts (split-string (file-loc filename) "/")) 84 | (name (file-name filename)) 85 | (partial-stem (ix: loc-parts (range n-at end+)))) 86 | (concat (apply #'dircat partial-stem) (if (> (length partial-stem) 0) "/" "") name))) 87 | 88 | (defun rep-underscores (str with) 89 | (replace-string-in-string " " with str)) 90 | 91 | (defun remove-string (string string-to-remove) 92 | (replace-string-in-string string-to-remove "" string)) 93 | 94 | (defun rename-file-if-different (file new-name &rest args) 95 | (if (not (string= file new-name)) 96 | (apply #'rename-file file new-name args) 97 | nil)) 98 | 99 | (defun* remove-spaces (filename &optional (rep "_")) 100 | (rename-file-if-different filename 101 | (replace-regexp-in-string 102 | (rx whitespace) 103 | rep 104 | filename))) 105 | 106 | (defmacro with-working-directory (dir &rest body) 107 | (with-gensyms (hold-dir%) 108 | `(let ((,hold-dir% (wd))) 109 | (unwind-protect 110 | (progn 111 | (cd ,dir) 112 | ,@body) 113 | (cd ,hold-dir%))))) 114 | 115 | (defun* remove-spaces-in-dir (directory) 116 | (with-working-directory directory 117 | (loop for f in (sh "ls -1") 118 | do 119 | (remove-spaces f)))) 120 | 121 | (defun remove-spaces-in-tree (root) 122 | (with-working-directory root 123 | (remove-spaces-in-dir (wd)) 124 | (let ((sub-dirs 125 | (filter #'file-directory-p 126 | (sh "ls -1")))) 127 | (loop for s in sub-dirs do 128 | (print s) 129 | (remove-spaces-in-tree s))))) 130 | 131 | (provide 'scripting) 132 | 133 | -------------------------------------------------------------------------------- /scripting.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Wed Nov 30 14:43:38 2011 3 | ;;; from file /home/toups/elisp/utils/scripting.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\300\301!\210\300\302!\210\300\303!\210\300\304!\207" [require utils functional with-stack stack-words] 2) 17 | (defalias 'dircat #[(&rest args) "\301\302\303\304\305\306\"!\"\307\"\207" [args join filter #[(%1) "\301\230?\207" [%1 ""] 2] flatten mapcar #[(&rest #1=#:clambdal-arglist-56538) "\301\302\303\304C\"\"\207" [#1# apply split-string append "/"] 5] "/"] 7]) 18 | (byte-code "\303\304\305\306\307\"\"\310\304\207" [*file-info-alist* *file-info-alist-keys* *simple-file-info* (("%a" (:access-rights-in-octal (lambda (x) x))) ("%A" (:access-rights-in-human-readable-form (lambda (x) x))) ("%b" (:number-of-blocks-allocated-see-%b string-to-number)) ("%B" (:the-size-in-bytes-of-each-block-reported-by-%b string-to-number)) ("%d" (:device-number-in-decimal string-to-number)) ("%D" (:device-number-in-hex (lambda (x) x))) ("%f" (:raw-mode-in-hex (lambda (x) x))) ("%F" (:file-type (lambda (x) x))) ("%g" (:group-id-of-owner (lambda (x) x))) ("%G" (:group-name-of-owner (lambda (x) x))) ("%h" (:number-of-hard-links (lambda (x) x))) ("%i" (:inode-number (lambda (x) x))) ("%n" (:file-name (lambda (x) x))) ("%N" (:quoted-file-name-with-dereference-if-symbolic-link (lambda (x) x))) ("%o" (:i/o-block-size (lambda (x) x))) ("%s" (:total-size-in-bytes string-to-number)) ("%t" (:major-device-type-in-hex (lambda (x) x))) ("%T" (:minor-device-type-in-hex (lambda (x) x))) ("%u" (:user-id-of-owner (lambda (x) x))) ("%U" (:user-name-of-owner (lambda (x) x))) ("%x" (:time-of-last-access (lambda (x) x))) ("%X" (:time-of-last-access-as-seconds-since-epoch string-to-number)) ("%y" (:time-of-last-modification (lambda (x) x))) ("%Y" (:time-of-last-modification-as-seconds-since-epoch string-to-number)) ("%z" (:time-of-last-change (lambda (x) x))) ("%Z" (:time-of-last-change-as-seconds-since-epoch string-to-number))) mapcar comp car cadr (("%n" (:name (lambda (x) x))) ("%Y" (:last-change string-to-number)) ("%s" (:size string-to-number)))] 4) 19 | #@71 Not documented 20 | 21 | (fn FILE &optional (FORMAT-ALIST *simple-file-info*)) 22 | (defalias 'file-info #[(file &rest #1=#:--cl-rest--) "\203\f\211A@\202 \203\306\307\310\311G\\D\"\210\312\313\314\315\n\"\316\"\317Q\320\321\322 \f#@\316\"\323\314\324\315\325\"\n\"\326\327 \n#\"+\207" [#1# *simple-file-info* format-alist format file parts signal wrong-number-of-arguments file-info 2 "--format=\"" join mapcar car " " "\"" split-string shf "stat -t %s %s" zip comp cadr mapcar* #[(part alist-part) "\211A@)\211A@)\211 !)\207" [alist-part x f part] 3]] 6 (#$ . 2460)]) 23 | (defalias 'file-size #[(file) "\301\302\303\"\304\"\207" [file alist file-info (("%s" (:size string-to-number))) :size] 4]) 24 | (defalias 'file-loc #[(filename) "\305\211\306 B\211\211A@\307\n! B)\310 \210\311 \210\310 \210\312 B\211\211A@ \211A@\313 \f\" B* @*\207" [*retain-stack* *stack* #1=#:stack-temp-156540 #2=#:stack-temp-256543 #3=#:stack-temp-156542 nil (split-string filename "/") eval stack-reverse- stack-cdr- "/" join] 4]) 25 | (defalias 'file-name #[(filename) "\303\211\304 B\211\211A@\305\n! B)\306 \210\307 \210 @*\207" [*retain-stack* *stack* #1=#:stack-temp-156545 nil (split-string filename "/") eval stack-reverse- stack-car-] 3]) 26 | (defalias 'file-name-flatten-with #[(filename rep) "\302\303\304\305\306\"\" \"\207" [filename rep join filter #[(x) "\301=\206\302\230\206\303\230\206\304\230\206\305\230?\207" [x nil "" " " "." ".."] 2] split-string "/"] 6]) 27 | #@50 Not documented 28 | 29 | (fn FILENAME &optional (N-IN 0)) 30 | (defalias 'pluck #[(filename &rest #1=#:--cl-rest--) "\203\f\211A@\202 \306\203\307\310\311\312G\\D\"\210\313\314\315\n!\316\"!\317\n!\313 \211GS G\320 \321 !\"+!\322\323\"G\306V\203P\316\202Q\324\fQ,\207" [#1# n-in filename loc-parts name #2=#:ix-lst56546 0 signal wrong-number-of-arguments pluck 2 reverse split-string file-loc "/" file-name elts range apply dircat "" end end+ partial-stem] 6 (#$ . 3943)]) 31 | #@50 Not documented 32 | 33 | (fn FILENAME &optional (N-AT 0)) 34 | (defalias 'clip #[(filename &rest #1=#:--cl-rest--) "\203\f\211A@\202 \306\203\307\310\311\312G\\D\"\210\313\314\n!\315\"\316\n! \211GS G\317 \320 \"\"+\321\322\"G\306V\203N\315\202O\323\fQ,\207" [#1# n-at filename loc-parts name #2=#:ix-lst56547 0 signal wrong-number-of-arguments clip 2 split-string file-loc "/" file-name elts range apply dircat "" end end+ partial-stem] 6 (#$ . 4433)]) 35 | (defalias 'rep-underscores #[(str with) "\302\303 #\207" [with str replace-string-in-string " "] 4]) 36 | (defalias 'remove-string #[(string string-to-remove) "\302\303 #\207" [string-to-remove string replace-string-in-string ""] 4]) 37 | (defalias 'rename-file-if-different #[(file new-name &rest args) " \230?\205 \303\304 \n$\207" [file new-name args apply rename-file] 5]) 38 | #@51 Not documented 39 | 40 | (fn FILENAME &optional (REP "_")) 41 | (defalias 'remove-spaces #[(filename &rest #1=#:--cl-rest--) "\203\f\211A@\202 \303\203\304\305\306\307G\\D\"\210\310\n\311\312 \n#\")\207" [#1# rep filename "_" signal wrong-number-of-arguments remove-spaces 2 rename-file-if-different replace-regexp-in-string "[[:space:]]"] 6 (#$ . 5278)]) 42 | (defalias 'with-working-directory '(macro . #[(dir &rest body) "\303\304!\305\306BC\307\310\311 D\nBB\311DEE)\207" [hold-dir% dir body gensym "hold-dir%" let ((wd)) unwind-protect progn cd] 6])) 43 | (defalias 'remove-spaces-in-dir #[(directory) "\304 \305\216\306 !\210\307\310!\311\n:\203\"\n@\312 !\210\nA\211\202,\311\207" [#1=#:hold-dir%56548 directory #2=#:--cl-var-- f wd ((cd #1#)) cd sh "ls -1" nil remove-spaces] 3]) 44 | (defalias 'remove-spaces-in-tree #[(root) "\305 \306\216\307 !\210\310\305 !\210\311\312\313\314!\"\211\315 :\2030 @\316\f!\210\317\f!\210 A\211\202-\315\207" [#1=#:hold-dir%56549 root sub-dirs #2=#:--cl-var-- s wd ((cd #1#)) cd remove-spaces-in-dir filter file-directory-p sh "ls -1" nil print remove-spaces-in-tree] 5]) 45 | (provide 'scripting) 46 | -------------------------------------------------------------------------------- /sets.el: -------------------------------------------------------------------------------- 1 | (provide 'sets) 2 | (require 'utils) 3 | (require 'cl) 4 | 5 | (defun* make-set (members &optional (pred #'equal)) 6 | (alist>> :values (unique members pred) 7 | :pred pred)) 8 | 9 | (defun predicate-of-set (set) 10 | (alist set :pred)) 11 | 12 | (defun values-of-set (set) 13 | (alist set :values)) 14 | 15 | (defun check-set-compat (set1 set2) 16 | (if (not (equal 17 | (predicate-of-set set1) 18 | (predicate-of-set set2))) 19 | (error "Can't operate on sets with distinct predicates.") 20 | t)) 21 | 22 | (defun* set-union (set1 set2) 23 | (check-set-compat set1 set2) 24 | (make-set (unique (append (values-of-set set1) 25 | (values-of-set set2)) (predicate-of-set set1)) 26 | (predicate-of-set set1))) 27 | 28 | (defun in-set (object set) 29 | ($ object in (values-of-set set) (predicate-of-set set))) 30 | (defun add-to-set (set object) 31 | (if (in-set object set) set 32 | (alist-cons set :values object))) 33 | 34 | (defun set-intersection (set1 set2) 35 | (check-set-compat set1 set2) 36 | (let ((vals (values-of-set (set-union set1 set2)))) 37 | (make-set 38 | (filter 39 | (lambda (item) 40 | (and ($ item in-set set1) 41 | ($ item in-set set2))) 42 | vals) 43 | (predicate-of-set set1)))) 44 | 45 | (defun set-difference (set1 set2) 46 | (check-set-compat set1 set2) 47 | (let ((v1 (values-of-set set1)) 48 | (v2 (values-of-set set2))) 49 | (filter 50 | (lambda (i1) 51 | (not ($ i1 in-set set2))) 52 | v1))) 53 | 54 | (defun set-count (set) 55 | (length (values-of-set set))) 56 | 57 | (defun set-equality (set1 set2) 58 | (check-set-compat set1 set2) 59 | (= (set-count set1) 60 | (set-count (set-union set1 set2)))) 61 | -------------------------------------------------------------------------------- /simplified-lambda-list-parser.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'monad-parse) 3 | (require 'functional) 4 | (provide 'simplified-lambda-list-parser) 5 | 6 | (defun not-lambda-list-sentinal (symbol) 7 | "Returns true for anything that isn't in '(&rest &optional &key)." 8 | (and (not (eq '&rest symbol)) 9 | (not (eq '&key symbol)) 10 | (not (eq '&optional symbol)))) 11 | (defun lambda-list-sentinal (symbol) 12 | "Returns true for anything that is in '(&rest &optional &key)." 13 | (or (eq '&rest symbol) 14 | (eq '&optional symbol) 15 | (eq '&key symbol))) 16 | (defun lambda-list-tail-sentinal (symbol) 17 | "Returns true for either '&rest or '&key, which are mutually exclusive in a lambda list." 18 | (or (eq '&rest symbol) 19 | (eq '&key symbol))) 20 | 21 | 22 | (defun =not-lambda-list-sentinal () 23 | "Return a parser which parses a single item which is not a lambda list sentinal." 24 | (=satisfies #'not-lambda-list-sentinal)) 25 | (defun =lambda-list-tail-sentinal () 26 | "Return a parser which parses a single item which is a lambda list sentinal." 27 | (=satisfies #'lambda-list-tail-sentinal)) 28 | 29 | (defun =regular-args () 30 | "Return a parser which gets the regular argument symbols of a lambda list, 31 | that is, the symbols up to the first lambda list sentinal." 32 | (=let* [_ (zero-or-more (=not-lambda-list-sentinal))] 33 | _)) 34 | 35 | (defun symbol-or-proper-pair (o) 36 | "Returns true for either a naked symbol, a list of only one symbol, or a list 37 | with two elements, a symbol and a form, which is an arbitrary lisp expression." 38 | (or (not-lambda-list-sentinal o) 39 | (and (listp o) 40 | (symbolp (car o)) 41 | (<= (length o) 2)))) 42 | 43 | (defun =maybe-optional-arg () 44 | "Returns a parser which parses a single argument representing a symbol and its 45 | default value, or a symbol. That is, x, (x) or (x 10), as examples." 46 | (=satisfies #'symbol-or-proper-pair)) 47 | 48 | (defun =optional-args () 49 | "Returns a parser which parses optional arguments from a lambda list. The 50 | parses returns a list of these args." 51 | (=let* [sentinal (=satisfies (par #'eq '&optional)) 52 | args (zero-or-more (=maybe-optional-arg))] 53 | args)) 54 | 55 | (defun =key-args () 56 | "Returns a parser which parses the arguments of the &key part of a lambda list, 57 | and returns the list of argument forms." 58 | (=let* [sentinal (=satisfies (par #'eq '&key)) 59 | args (zero-or-more (=maybe-optional-arg))] 60 | args)) 61 | 62 | (defun =rest-arg () 63 | "Returns a parser which parses the arguments of the &rest part of a lambda list, 64 | and returns the symbol which will contain the tail of the passed in args." 65 | (=let* [sentinal (=satisfies (par #'eq '&rest)) 66 | arg (=not-lambda-list-sentinal)] 67 | (if arg arg (error "Lambda list parser error - &rest needs a symbol to bind the rest to.")))) 68 | 69 | (defun =lambda-list-tail () 70 | "Returns a parser which parses the tail of a lambda list, either an &key for, or an &rest form, 71 | but not both. The context using this parser should check to see that this form exhausts the lambda list, 72 | because not doing so indicates an error." 73 | (=let* [sentinal (=satisfies #'lambda-list-tail-sentinal) 74 | part/s 75 | (cond ((eq sentinal '&rest) 76 | (=satisfies #'not-lambda-list-sentinal)) 77 | ((eq sentinal '&key) 78 | (zero-or-more (=maybe-optional-arg))))] 79 | (list (case sentinal 80 | (&rest :rest) 81 | ('&key :key)) 82 | part/s))) 83 | 84 | (defun =lambda-list () 85 | "Returns a parser which parses a lambda list into an alist with :normal, 86 | :optional, :key or :rest entries, containing the appropriate forms." 87 | (=let* [normals (zero-or-more (=regular-args)) 88 | optionals (=maybe (=optional-args)) 89 | tail (=maybe (=lambda-list-tail))] 90 | (let ((table (alist>> :optional optionals :normal normals))) 91 | (if tail 92 | (cons tail table) 93 | table)))) 94 | 95 | (defun simple-parse-lambda-list (lambda-list) 96 | "Parse the lambda list in LAMBDA-LIST and return a table of the lambda list information where 97 | :normal holds the normal argument symbols 98 | :optional holds the optional arguments, as either symbol or symbol/form pairs 99 | :rest holds the symbol to bind the tail of the arguments to 100 | and :key holds the key symbols or symbol/val pairs. 101 | 102 | Pairs are proper lists, rather than PAIRS in the strict sense. Throws errors if the lambda 103 | list is not parsable." 104 | (let* ((result-and-state (funcall (=lambda-list) (->in lambda-list))) 105 | (result (car (car result-and-state))) 106 | (remainder (input-as-list (cdr (car result-and-state))))) 107 | (if remainder (error "Can't figure out how to parse the lambda-list tail %S" remainder) 108 | result))) 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | -------------------------------------------------------------------------------- /skip-lists.el: -------------------------------------------------------------------------------- 1 | (provide 'skip-lists) 2 | (require 'cl) 3 | 4 | (defstruct sl-node 5 | (val) 6 | (links)) 7 | 8 | (defun make-participation (max div) 9 | -------------------------------------------------------------------------------- /sqlite.el: -------------------------------------------------------------------------------- 1 | (require 'functional) 2 | (require 'monad-parse) 3 | (provide 'sqlite) 4 | 5 | (setq *sqlite-bin* "/usr/bin/sqlite3") 6 | 7 | (defmacro declare-literal-symbol-parsers (&rest symbols) 8 | `(progn 9 | ,@(loop for s in symbols collect 10 | `(defun ,(internf "=lit-%s" s) () 11 | (=lit-sym ',s))) 12 | ',(mapcar 13 | (pal #'internf "=lit-%s") symbols))) 14 | 15 | (declare-literal-symbol-parsers 16 | insert 17 | replace 18 | or 19 | rollback 20 | abort 21 | replace 22 | fail 23 | ignore 24 | into 25 | default 26 | values) 27 | 28 | (defun =insert-modifier () 29 | (=let* [_ (=lit-or) 30 | modifier 31 | (=or 32 | (=lit-rollback) 33 | (=lit-abort) 34 | (=lit-replace) 35 | (=lit-fail) 36 | (=lit-ignore))] 37 | modifier)) 38 | 39 | (defun =parse-database-info () 40 | (=let* [res (=or 41 | (=satisfies #'stringp) 42 | (=and (=satisfies #'listp) 43 | (=satisfies (comp #'stringp #'car)) 44 | (=satisfies (comp #'stringp #'cdr))))] 45 | (if res 46 | (if (listp res) 47 | (alist>> :name (car res) 48 | :table (cdr res))) 49 | res))) 50 | 51 | (defun =default-values-seq () 52 | (=let* [def (=satisfies (par 'eq 'default)) 53 | val (=satisfies (par 'eq 'values))] 54 | 'default-values)) 55 | 56 | (defun =parse-name-values () 57 | (=let* [names (=satisfies 58 | (lambda (thing) 59 | (and (listp thing) 60 | (and-over #'symbolp thing)))) 61 | sigil (=lit-values) 62 | values (=satisfies 63 | (lambda (thing) 64 | (listp thing) 65 | (= (length thing) (length names))))] 66 | (alist>> :names names :values values))) 67 | 68 | (defun =parse-tail-info () 69 | (=or (=default-values-seq) 70 | (=parse-name-values))) 71 | 72 | (defun parse-insert-statement () 73 | (=let* [form-type (=or 74 | (=lit-replace) 75 | (=lit-insert)) 76 | modifier (=maybe (=insert-modifier)) 77 | _ (=lit-into) 78 | database-info (=parse-database-info) 79 | tail (=parse-tail-info)] 80 | (alist>> :form-type form-type 81 | :modifier modifier 82 | :database-info database-info 83 | :tail tail))) 84 | 85 | 86 | (parse-sequence (parse-insert-statement) '(insert into ("database" . "table") default values)) 87 | 88 | 89 | 90 | (defun escape-quote (s) 91 | (replace-regexp-in-string (rxq "'") 92 | "''" s)) 93 | 94 | (defun sqlify (datum) 95 | (cond 96 | ((stringp datum) 97 | (format "'%s'" (escape-quote datum))) 98 | ((numberp datum) 99 | (format "%d" datum)) 100 | ((keywordp datum) 101 | (format "'(make-keyword \"%s\")'" datum)) 102 | ((symbolp datum) 103 | (format "'(intern \"%s\")'" datum)) 104 | ((listp datum) 105 | (format "'%S'" (escape-quote (format "%S" datum)))))) 106 | 107 | (defun sql-create (table 108 | 109 | (defun atomic-insert (database-file 110 | table 111 | fields 112 | values) 113 | (let* ((statement 114 | (format "insert into %s (%s) values (%s);\n" 115 | table 116 | (join (mapcar (cl #'format "%s") 117 | fields) ", ") 118 | (join (mapcar #'sqlify values) ", "))) 119 | (file-name (cadr 120 | (with-write-temp-file 121 | (insert statement))))) 122 | (prog1 (with-temp-buffer 123 | (call-process *sqlite-bin* file-name (current-buffer) nil database-file) 124 | (buffer-substring (point-min) (point-max))) 125 | (delete-file file-name)))) 126 | 127 | 128 | 129 | 130 | 131 | -------------------------------------------------------------------------------- /stack-monads.el: -------------------------------------------------------------------------------- 1 | (require 'with-stack) 2 | (require 'stack-words) 3 | (|||p 1 2 3 stack) 4 | (|||p 1 2 3 4 stack '(drop-all) dip) 5 | (|||p '{ 'a 'b 'c '{ 'd '} 'e '} stack '(drop-all) dip reverse) 6 | 7 | 8 | 9 | (||| word: monad{ 10 | stack '(drop-all) dip reverse cdr 11 | '{monad swap cons 12 | '{monad 'monad} split-by-match end:) 13 | 14 | (|||p '({monad a b c d e monad} cats dogs raining) push-list monad{) 15 | -------------------------------------------------------------------------------- /stream-scratch.el: -------------------------------------------------------------------------------- 1 | Lets use these functions to write some theoretical `social networking` 2 | functions. 3 | 4 | (defvar *no-one* nil) 5 | (defvar friends-db (alist>> 6 | :leo (list :ted :steve :fred :lea :jane) 7 | :ted (list :leo :steve :lea) 8 | :steve (list :leo) 9 | :fred (list :leo :lea :jane) 10 | :lea (:leo 11 | (defun friends-of (person) 12 | 13 | 14 | 15 | (require 'monad-stream) 16 | 17 | (stream-plus^i (streamc 1 2 3) (lambdac () (stream nil))) 18 | 19 | (stream-plus-rec (streamc 1 2 3) (lambdac () (stream nil))) 20 | 21 | (reverse '(a b c . d)) 22 | 23 | (let ((x '(1))) 24 | (setf (cdr x) 10) 25 | x) 26 | 27 | (defun improper-suffix (list item &optional past) 28 | (let* ((cp (copy-list list)) 29 | (cp-cdr (cdr cp))) 30 | (loop until ( = (length cp-cdr) 1) do 31 | (setq cp-cdr (cdr cp-cdr))) 32 | (setf (cdr cp-cdr) item) 33 | cp)) 34 | 35 | 36 | (stream-bind ones (lambda (x) (stream (+ x 1)))) 37 | 38 | (with-monad monad-stream 39 | (stream-cdr (stream-cdr 40 | (mlet* monad-stream ((x (stream 1 2 3)) 41 | (y (stream 4 5 6))) 42 | (+ x y))))) 43 | 44 | (stream-cdr (stream-cdr (stream-cdr 45 | (mlet*_ monad-stream ((x (stream 1 2 3)) 46 | (y (stream 4 5 6))) 47 | (stream-return (+ x y)))))) 48 | 49 | (take-n (mlet*_ monad-stream ((x (streamc 1 2 3)) 50 | (y (streamc 4 5 6))) 51 | (cons (+ x y) nil)) 3) 52 | 53 | (fmakunbound 'choice) 54 | 55 | (defmacro choice (a &optional f) 56 | `(cons ,a ,f)) 57 | 58 | (defun choice (a &optional f) 59 | (cons a f)) 60 | 61 | (with-monad monad-stream 62 | (m-return (+ 1 2))) 63 | 64 | (cons (+ 1 1) nil) 65 | (choice (+ 1 1) nil) 66 | 67 | (choice 'x nil) 68 | 69 | (defun add-streams (stream1 stream2) 70 | (stream-case stream1 71 | nil 72 | ((a1) 73 | (stream-case stream2 74 | nil 75 | ((a2) (choice (+ a1 a2) nil)) 76 | ((a2 f2) 77 | (choice 78 | 79 | (defvar fibs (choice 1 (lambda () (choice 1 (lambda () 80 | ( -------------------------------------------------------------------------------- /testbuffer.txt: -------------------------------------------------------------------------------- 1 | 10.0 10 b c d "this is a \"string" s1 s2 s3x 2 | -------------------------------------------------------------------------------- /thunk.el: -------------------------------------------------------------------------------- 1 | (require 'macro-utils) 2 | 3 | (defmacro* thunk (&body body) 4 | (let* ((syms (unique (filter #'symbolp (flatten body)))) 5 | (free-syms 6 | (filter 7 | (lambda (x) 8 | ($ (count-free-usages x (cons 'progn body)) > 0)) 9 | syms))) 10 | `(lexical-let ,(loop for s in free-syms collect (list s s)) 11 | (lambda () ,@body)))) 12 | 13 | (setf test (let ((x 10)) 14 | (thunk (+ x x)))) 15 | 16 | (defun force (thunk) 17 | (funcall thunk)) 18 | 19 | (force test) 20 | 21 | (macroexpand '(thunk (+ x x))) 22 | (count-free-usages '+ '(+ x x)) -------------------------------------------------------------------------------- /track-life.el: -------------------------------------------------------------------------------- 1 | (setq *track-life-file* "~/track-life.el") 2 | (setq *track-life-tags* ()) 3 | 4 | (defmacro def-track-life-tag (tag desc) 5 | `(alist>> *track-life-tags* ,tag ,desc)) -------------------------------------------------------------------------------- /tree-monads.el: -------------------------------------------------------------------------------- 1 | (require 'utils) 2 | (require 'monads) 3 | (require 'functional) 4 | 5 | (defun* btcons (val &optional (left nil) (right nil)) 6 | (cons val 7 | (vector left right))) 8 | 9 | (defun btree? (val) 10 | (and (consp val) 11 | (vectorp (cdr val)))) 12 | 13 | (defun btleft (node) 14 | (first (cdr node))) 15 | 16 | (defun btright (node) 17 | (second (cdr node))) 18 | 19 | (defun btleaf? (val) 20 | (and (btree? val) 21 | (eq (btleft val) nil) 22 | (eq (btright val) nil))) 23 | 24 | (defun btnode? (val) 25 | (not (btleaf? val))) 26 | 27 | (defun btnode-val (val) 28 | (car val)) 29 | 30 | (defun left-nil? (node) 31 | (not (btleft node))) 32 | 33 | (defun right-nil? (node) 34 | (not (btright node))) 35 | 36 | (defun graft-left (tree sub-tree) 37 | (cond 38 | ((not tree) sub-tree) 39 | ((not sub-tree) tree) 40 | ((left-nil? tree) (btcons 41 | (btnode-val tree) 42 | sub-tree 43 | (btright tree))) 44 | (t (btcons (btnode-val tree) 45 | (graft-left (btleft tree) sub-tree) 46 | (btright tree))))) 47 | 48 | (defun graft-right (tree sub-tree) 49 | (cond 50 | ((not tree) sub-tree) 51 | ((not sub-tree) tree) 52 | ((right-nil? tree) (btcons 53 | (btnode-val tree) 54 | (btleft tree) 55 | sub-tree 56 | )) 57 | (t (btcons (btnode-val tree) 58 | (btleft tree) 59 | (graft-right (btright tree) sub-tree) 60 | )))) 61 | 62 | (graft-right (graft-left (btcons 10) (btcons 9)) (btcons 11)) 63 | 64 | (defun bt-bind (v f) 65 | (cond 66 | ((eq nil v) nil) 67 | ((or (btleaf? v) 68 | (btnode? v)) 69 | (let ((res (funcall f (btnode-val v)))) 70 | (graft-right (graft-left res (bt-bind (btleft v) f)) 71 | (bt-bind (btright v) f)))) 72 | )) 73 | 74 | (bt-bind (btcons 10 (btcons 9) (btcons 11)) 75 | (lambda (v) (btcons (+ v 1)))) 76 | 77 | (setq monad-btree 78 | (tbl! :m-return #'btcons 79 | :m-bind 80 | #'bt-bind)) 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /trie.el: -------------------------------------------------------------------------------- 1 | (provide 'trie) 2 | (require 'utils) 3 | 4 | (defun trie-children? (trie) 5 | (cdr trie)) 6 | (defun trie-key (trie) 7 | (car (car trie))) 8 | (defun trie-value (trie) 9 | (cdr (car trie))) 10 | (defun trie-left (trie) 11 | (car (cdr trie))) 12 | (defun trie-right (trie) 13 | (cdr (cdr trie))) 14 | 15 | (defun trie-node (key val left right) 16 | (cons (cons key val) (cons left right))) 17 | 18 | (defun retrieve- (trie key) 19 | (cond ((not trie) nil) 20 | ((not key) nil) 21 | (otherwise 22 | (let ((key-key (car key)) 23 | (children (trie-children? trie))) 24 | (cond 25 | ((and (eq key-key (car trie)) 26 | (not trie-children?)) 27 | (trie-value trie))))))) 28 | 29 | (cleave '(min max) (coerce "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890~!@#$%^&*()_+=-`\"':;.,>>)) 3 | (flet ((drop-last (x) 4 | (let* ((s (format "%s" x)) 5 | (n (length s))) 6 | (intern (substring s 0 (- n 1)))))) 7 | (loop for 8 | name in 9 | '(base- deca- hecto- kilo- mega- giga- tera- peta- exa- zetta- yotta-) and 10 | sub-name in 11 | '(base- deci- centi- milli- micro- nano- pico- femto- atto- zepto- yocto-) and 12 | num in 13 | '(0 1 2 3 6 9 12 15 18 21 24) do 14 | (eval `(defun ,(drop-last (internf "from-%s" name)) (v) (* v ,(expt 10.0 num)))) 15 | (eval `(defun ,(drop-last (internf "in-%s" name)) (v) (/ v ,(expt 10.0 num)))) 16 | (eval `(defun ,(drop-last (internf "from-%s" sub-name)) (v) (* v ,(expt 10.0 (- num))))) 17 | (eval `(defun ,(drop-last (internf "in-%s" sub-name)) (v) (/ v ,(expt 10.0 (- num))))) 18 | 19 | (eval `(univalent-stack-words ,(drop-last (internf "from-%s" name)) 20 | ,(drop-last (internf "in-%s" name)) 21 | ,(drop-last (internf "from-%s" sub-name)) 22 | ,(drop-last (internf "in-%s" sub-name)))) 23 | (setq *units-map* 24 | (alist>> *units-map* 25 | (read (concat ":" (format "%s" (drop-last name)))) 26 | (alist>> :from (eval (read (format "#'%s" (drop-last (internf "from-%s" name))))) 27 | :in (eval (read (format "#'%s" (drop-last (internf "in-%s" name)))))) 28 | (read (concat ":" (format "%s" (drop-last sub-name)))) 29 | (alist>> :from (eval (read (format "#'%s" (drop-last (internf "from-%s" sub-name))))) 30 | :in (eval (read (format "#'%s" (drop-last (internf "in-%s" sub-name)))))))) 31 | (print name) 32 | (print num))) 33 | (provide 'units) 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /units.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Wed Nov 30 14:43:17 2011 3 | ;;; from file /home/toups/elisp/utils/units.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (byte-code "\306\307!\210\310 \311\312!\211\205\312K\313\216\312\314M\210\315\316\317\316\320\316-.//:\203$-:\203$\f:\203$/@.-@\f@\321\322\312\323\324.\"!\325\326\327\330\331 \"EF!\210\321\322\312\323\332.\"!\333\334\327\330\335 \"EF!\210\321\322\312\323\324 \"!\336\326\327\330\337 [\"EF!\210\321\322\312\323\332 \"!\340\334\327\330\341 [\"EF!\210\321\342\312\323\324.\"!\312\323\332.\"!\312\323\324 \"!\312\323\332 \"!\257!\210\310\343\344\345\346\312.!\"P!\310\347\321\343\345\350\312\323\324.\"!\"!!\351\321\343\345\350\312\323\332.\"!\"!!$\343\344\345\346\312 !\"P!\310\347\321\343\345\350\312\323\324 \"!\"!!\351\321\343\345\350\312\323\332 \"!\"!!$%\352.!\210\352 !\210/A/-A-\fA\202'. \353\354!\207" [*units-map* #1=#:--cl-letf-bound-- #2=#:--cl-letf-save-- num #:--cl-var-- sub-name require with-stack alist>> fboundp drop-last ((byte-code "\203 \302 M\210\202\303\302!\210\302\207" [#1# #2# drop-last fmakunbound] 2)) #[(x) "\303\304\"\211G\305 \306\nSO!*\207" [x s n format "%s" intern 0] 5] (base- deca- hecto- kilo- mega- giga- tera- peta- exa- zetta- yotta-) nil (base- deci- centi- milli- micro- nano- pico- femto- atto- zepto- yocto-) (0 1 2 3 6 9 12 15 18 21 24) eval defun internf "from-%s" (v) * v expt 10.0 "in-%s" (v) / 10.0 (v) 10.0 (v) 10.0 univalent-stack-words read ":" format "%s" :from "#'%s" :in print provide units #:--cl-var-- name #:--cl-var--] 18) 17 | -------------------------------------------------------------------------------- /virtues.el: -------------------------------------------------------------------------------- 1 | (require 'defn) 2 | (require 'org) 3 | 4 | (defvar all-virtues (reverse (list 5 | "humility" 6 | "chastity" 7 | "tranquility" 8 | "cleanliness" 9 | "moderation" 10 | "justice" 11 | "sincerity" 12 | "industry" 13 | "frugality" 14 | "resolution" 15 | "order" 16 | "silence" 17 | "temperance"))) 18 | 19 | (defn default-virtue-sums [] 20 | (loop with sums = (tbl!) 21 | for v in 22 | (list 23 | "humility" 24 | "chastity" 25 | "tranquility" 26 | "cleanliness" 27 | "moderation" 28 | "justice" 29 | "sincerity" 30 | "industry" 31 | "frugality" 32 | "resolution" 33 | "order" 34 | "silence" 35 | "temperance") 36 | do 37 | (tbl! sums v 0) 38 | (tbl! sums (concat v "-count") 0) 39 | finally 40 | (return sums))) 41 | 42 | (defn chomp-properties [str] 43 | (chomp (substring-no-properties str))) 44 | 45 | (defn slurp-virtue-file 46 | ([filename sums] 47 | (dlet [buf (find-file-noselect filename)] 48 | (with-current-buffer buf 49 | (loop for i from 2 to 14 do 50 | (goto-line i) 51 | (dlet [virtue (chomp-properties (org-table-get-field 1)) 52 | score (string-to-number (chomp-properties (org-table-get-field 2)))] 53 | (tbl! sums virtue (+ score (tbl sums virtue))) 54 | (tbl! sums (concat virtue "-count") (+ 1 (tbl sums (concat virtue "-count"))))))) 55 | (kill-buffer buf) 56 | sums)) 57 | ([filename] 58 | (slurp-virtue-file filename (default-virtue-sums)))) 59 | 60 | (defn average-score [sums virtue] 61 | (round (/ (float (tbl sums virtue)) 62 | (float (tbl sums (concat virtue "-count")))))) 63 | 64 | (defn average-scores [sums] 65 | (loop with averages = (tbl!) 66 | for key in all-virtues do 67 | (tbl! averages key (average-score sums key)) 68 | finally (return averages))) 69 | 70 | ;(keyshash sums) 71 | 72 | ; (setq sums (slurp-virtue-file "/home/toups/Dropbox/gtd/virtues/07_14_2009.org")) 73 | ; (average-scores sums) 74 | 75 | 76 | 77 | (defn n-spaces [n] 78 | (make-string n (car (coerce " " 'list)))) 79 | 80 | (defn print-virtue-table [averages] 81 | (let* ((max-len (apply #'max (mapcar #'length all-virtues))) 82 | (padded-virtues (mapcar 83 | (fn [v] (concat v (n-spaces (- max-len (length v))) ": ")) 84 | all-virtues))) 85 | (loop for vp in padded-virtues 86 | and 87 | virt in all-virtues do 88 | (insertf "%s %s\n" vp (make-string (tbl averages virt) ?*))))) 89 | 90 | (defvar *virtues-directory* "~/Dropbox/gtd/virtues") 91 | 92 | (defn org-file? [filename] 93 | (dlet [len (length filename)] 94 | (if ($ len < 4) nil 95 | (dlet [last-four (substring-no-properties filename (- len 4) len)] 96 | (string= last-four ".org"))))) 97 | 98 | (defn get-files [] 99 | (mapcar (fn [f] (concat *virtues-directory* "/" f)) (filter #'org-file? (directory-files *virtues-directory*)))) 100 | 101 | (defn find-averages-from-all-files [] 102 | (dlet [files (get-files) 103 | sums (foldl (fn [it ac] 104 | (slurp-virtue-file it ac)) 105 | (slurp-virtue-file (car files)) 106 | (cdr files))] 107 | (average-scores sums))) 108 | 109 | (defun show-averages-buffer () 110 | (interactive) 111 | (dlet [b (get-buffer-create "*virtues-average-buffer*")] 112 | (with-current-buffer b 113 | (clear-buffer) 114 | (print-virtue-table (find-averages-from-all-files))))) 115 | 116 | (provide 'virtues) 117 | 118 | 119 | 120 | 121 | 122 | 123 | -------------------------------------------------------------------------------- /vorg.el: -------------------------------------------------------------------------------- 1 | ;;; org-get-tags 2 | (defun vorg-goto-heading (heading) 3 | 4 | (let ((old-point (point))) 5 | (goto-char (point-min)) 6 | (loop with found = nil 7 | while (not 8 | (and (org-on-heading-p) 9 | (string= (org-get-heading) 10 | heading))) 11 | do 12 | (if (org-on-heading-p) 13 | (insert (org-get-heading))) 14 | (if (and (last-line?) 15 | (not found)) 16 | (progn 17 | (goto-char old-point) 18 | (error "Heading %s not found" heading)) 19 | (forward-line 1))))) 20 | 21 | -------------------------------------------------------------------------------- /vorg.elc: -------------------------------------------------------------------------------- 1 | ;ELC 2 | ;;; Compiled by toups@deluge on Tue Aug 30 14:21:47 2011 3 | ;;; from file /home/toups/elisp/utils/vorg.el 4 | ;;; in Emacs version 23.2.1 5 | ;;; with all optimizations. 6 | 7 | ;;; This file uses dynamic docstrings, first added in Emacs 19.29. 8 | 9 | ;;; This file does not contain utf-8 non-ASCII characters, 10 | ;;; and so can be loaded in Emacs versions earlier than 23. 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | (defalias 'vorg-goto-heading #[(heading) "`eb\210\303\304 \203\305 \n\230\2046\304 \203\305 c\210\306 \2030 \2040b\210\307\310\n\"\210\202\311y\210\202*\303\207" [old-point found heading nil org-on-heading-p org-get-heading last-line\? error "Heading %s not found" 1] 3]) 17 | --------------------------------------------------------------------------------