Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

fixed, at least, recur.

  • Loading branch information...
commit d09d1448de38d9601c16e1d8ca5dcc98f1423316 1 parent 55bda87
@VincentToups authored
View
59 chemistry.el
@@ -1,4 +1,4 @@
- (require 'with-stack)
+(require 'with-stack)
(require 'stack-words)
(require 'eperiodic)
(require 'defn)
@@ -110,12 +110,12 @@
(defun generate-conditions (alist)
(foldl (lambda (it ac)
(domonad< monad-seq
- [a-case ac
- component (cadr it)]
- (cons (list (car it) component) a-case)))
+ [a-case ac
+ component (cadr it)]
+ (cons (list (car it) component) a-case)))
(domonad< monad-seq
- [q (cadr (car alist))]
- (list (list (car (car alist)) q)))
+ [q (cadr (car alist))]
+ (list (list (car (car alist)) q)))
(cdr alist)))
(defun generate-conditions>> (&rest rest)
(generate-conditions (apply #'alist>> rest)))
@@ -136,8 +136,8 @@
(defun add-permutations (conditions-list condition-name values)
(domonad< monad-seq [c conditions-list
- v values]
- (alist>> c condition-name v)))
+ v values]
+ (alist>> c condition-name v)))
(defun keyword->string (kw)
(let ((s (format "%s" kw)))
@@ -146,9 +146,25 @@
(defun condition->filename (condition)
(||| lisp-val: (let ((keys (mapcar #'car condition)))
(foldl (lambda (it ac)
- (concatf (list ac "=%s=%0.6d")
- (keyword->string (car it))
- (cadr it)))
+ (if (cadr it)
+ (typecase (cadr it)
+ (float
+ (concatf (list ac "=%s=%0.6f")
+ (keyword->string (car it))
+ (cadr it)))
+ (number
+ (concatf (list ac "=%s=%0.6d")
+ (keyword->string (car it))
+ (cadr it)))
+ (symbol
+ (concatf (list ac "=%s=%s")
+ (keyword->string (car it))
+ (cadr it)))
+ (string
+ (concatf (list ac "=%s=%s")
+ (keyword->string (car it))
+ (cadr it))))
+ ac))
""
condition))
dup 1>length 1 swap 3>substring))
@@ -211,13 +227,13 @@
(defun generate-instructions (condition handler-alist final-volume volume-units)
- (format "for %s\n \t%s and fill to %f %sL"
+ (format "for %s\n \t\t%s and fill to %f %sL\n"
(print-condition condition)
(join (mapcar
(lambda (condition)
(let* ((key (car condition))
(handler (alist handler-alist key)))
- (funcall handler (cadr condition)))) condition) "\n\t")
+ (funcall handler (cadr condition)))) condition) "\n\t\t")
(funcall (alist-in *units-map* `(,volume-units :in)) final-volume)
(||| {volume-units} "%s" swap 2>format dup length 1 swap substring)))
@@ -291,22 +307,23 @@
keys)
"|"))
-(defun* generate-experiment-files (condition-args n-trials &optional (mixing-volume (from-milli 50)))
+(defun* generate-experiment-files (condition-args n-trials &optional (mixing-volume (from-milli 50))
+ (filter-function (always t)))
(print "WARNING Volumes other than 50 mil don't work correctly.")
(let* ((*final-volume-for-mixing* mixing-volume)
(keys (mapcar #'car condition-args))
- (raw-conditions (generate-conditions condition-args))
+ (raw-conditions (filter filter-function (generate-conditions condition-args)))
(conditions (||| {raw-conditions}
:samplePh 2>group-by-condition
- '( 1>permute-list ) map 1>ungroup))
+ '( 1>permute-list ) map 1>permute-list 1>ungroup))
(trials (range n-trials)))
(let ((instructions (find-file "instructions.md"))
(log (find-file "log.org")))
(with-current-buffer log
(kill-region (point-min) (point-max))
(insertf "| n | filename | trial | bufferPh | %s |\n" (alist-keys->org-mode-table-segment
- (mapcar (lambda (x) (list x x))
- keys) keys)))
+ (mapcar (lambda (x) (list x x))
+ keys) keys)))
(with-current-buffer instructions
(kill-region (point-min) (point-max)))
(loop for c in conditions and i from 1 do
@@ -324,9 +341,9 @@
(print "WARNING Volumes other than 50 mil don't work correctly.")
(let* ((raw-conditions (generate-conditions condition-args))
(conditions (||| {raw-conditions}
- :samplePh 2>group-by-condition
- '( 1>permute-list ) map 1>ungroup))
- (trials (range n-trials)))
+ :samplePh 2>group-by-condition
+ '( 1>permute-list ) map 1>permute-list 1>ungroup))
+ (trials (range n-trials)))
(let ((instructions (find-file "instructions.md"))
(log (find-file "log.org")))
(with-current-buffer log
View
BIN  chemistry.elc
Binary file not shown
View
10 def.el
@@ -0,0 +1,10 @@
+(require 'monad-parse)
+(require 'utils)
+
+(defun expr->let-clause (expr)
+ (cond
+ ((symbolp expr) (lambda
+
+(defmacro extlet (expr &rest body)
+ (cond
+ ((symbolp expr) `(
View
33 later.el
@@ -0,0 +1,33 @@
+(require 'cl)
+(require 'utils)
+
+(eval-when-compile-also
+ (defun single-symbol-list? (item)
+ (and (listp item)
+ (= (length item) 1)
+ (symbolp (car item))))
+ (defun binderish? (item)
+ (and (listp item)
+ (= (length item) 2)
+ (symbolp (car item))))
+
+ (defun with-form->binder (item)
+ (cond ((symbolp item )(list item item))
+ ((listp item)
+ (cond ((single-symbol-list? item)
+ (cons (car item) item))
+ ((binderish? item)
+ item)
+ (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item))))
+ (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item))))
+
+ (defmacro* later (expr &key (with nil) (with* nil))
+ (cond (with
+ `(lexical-let ,(mapcar #'with-form->binder with)
+ (later ,expr :with* ,with*)))
+ (with*
+ `(lexical-let* ,(mapcar #'with-form->binder with*)
+ (later ,expr)))
+ (t `(lambda () ,expr)))))
+
+(provide 'later)
View
BIN  later.elc
Binary file not shown
View
57 monad-parse.el
@@ -42,6 +42,8 @@
(ix :accessor index-of :initarg :index :initform 0)))
+
+
(defmethod input-empty? ((input <parser-input-string>))
(= (length (string-of input)) (index-of input)))
(defmethod input-empty-p ((input <parser-input-string>))
@@ -138,6 +140,15 @@
(list (cons (input-first input)
(input-rest input))))))
+(defun remaining (input)
+ (list (cons (input-as-string input) input)))
+
+(defun =or-strings (&rest args)
+ (apply #'=or (mapcar #'=string args)))
+
+(defun =or-stringsi (&rest args)
+ (apply #'=or (mapcar #'=stringi args)))
+
(lex-defun parser-items (n)
(lambda (input)
(let ((i 0)
@@ -148,7 +159,7 @@
(setq i (+ i 1))
(push (input-first input) ac )
(setq input (input-rest input)))
- (if (= (length ac) n) (list (cons (reverse ac) input) nil)))))
+ (if (= (length ac) n) (list (cons (reverse ac) input)) nil))))
(lex-defun parser-items->string (n)
(lambda (input)
@@ -161,7 +172,7 @@
(push (input-first input) ac )
(setq input (input-rest input)))
;(db-print (list n (length ac) (coerce (reverse ac) 'string)))
- (if (= (length ac) n) (list (cons (coerce (reverse ac) 'string) input) nil)))))
+ (if (= (length ac) n) (list (cons (coerce (reverse ac) 'string) input)) nil))))
(defun =string (str)
(lexical-let ((str str))
@@ -170,6 +181,17 @@
(if (string= x str)
(parser-return x)
(parser-fail))))))
+
+
+(defun =stringi (str)
+ (lexical-let ((str str))
+ (parser-bind (parser-items->string (length str))
+ (lambda (x)
+ (if (stringi= x str)
+ (parser-return str)
+ (parser-fail))))))
+
+
(defun =string->seq (str)
(lexical-let ((str str))
(parser-bind (parser-items->string (length str))
@@ -265,6 +287,13 @@
(rest (=one-or-more (=digit-char))))
(coerce (cons dot rest) 'string)))
+(lex-defun =decimal-part* (dec-string)
+ (=simple-let*
+ ((dot (=string dec-string))
+ (rest (=one-or-more (=digit-char))))
+ (coerce (cons ?. rest) 'string)))
+
+
(defun =integer-part ()
(=simple-let*
((digits (=zero-or-more (=digit-char))))
@@ -272,9 +301,20 @@
(defun =number->number ()
(=simple-let*
- ((int (=integer-part))
+ ((minus-sign (=maybe (=string "-")))
+ (int (=integer-part))
(dec (=maybe (=decimal-part))))
- (string-to-number (concat int dec))))
+ (let ((n (string-to-number (concat int dec))))
+ (if minus-sign (- n) n))))
+
+(lex-defun =number->number* (dec-string)
+ (=simple-let*
+ ((minus-sign (=maybe (=string "-")))
+ (int (=integer-part))
+ (dec (=maybe (=decimal-part* dec-string))))
+ (let ((n (string-to-number (concat int dec))))
+ (if minus-sign (- n) n))))
+
(lex-defun =or2 (p1 p2)
(lambda (input)
@@ -299,7 +339,6 @@
;; parsers)))
(lex-defun =not (parser)
- b
(lambda (input)
(let ((result (funcall parser input)))
(if result
@@ -366,6 +405,11 @@
_)
(parser-return nil)))
+(lex-defun zero-or-one (parser)
+ (=or (=let* [_ parser]
+ _)
+ (parser-return nil)))
+
(lex-defun zero-or-one-list (parser)
(=or (=let* [_ parser]
(list _))
@@ -477,5 +521,8 @@
#'symbolp
(par #'eq sym))))
+(defmacro* parser-let* (binders &body body)
+ `(lexical-mlet monad-parse ,binders ,@body))
+
(provide 'monad-parse)
View
BIN  monad-parse.elc
Binary file not shown
View
73 monad-text-parse.el
@@ -0,0 +1,73 @@
+(require 'utils)
+(require 'monads)
+(require 'recur)
+
+(defmacro when/not-empty (val &rest body)
+ (with-gensyms
+ (id)
+ `(let ((,id ,val))
+ (when (and ,id (not (empty? ,id)))
+ ,@body))))
+
+(defun match-string< (str)
+ (let ((str (format "%s" str)))
+ (enclose
+ (str)
+ (lambda (input)
+ (when input
+ (let* ((n (length str))
+ (k (min (length input) n))
+ (test (substring input 0 k))
+ (rest (substring input k)))
+ (if (string= test str)
+ (list (cons str rest))
+ nil)))))))
+
+(defun ->parser (thing)
+ (if (functionp thing) thing
+ (match-string< thing)))
+
+(defun text-parse-bind (parser* parser-producer)
+ (let ((parser* (->parser parser*)))
+ (enclose
+ (parser* parser-producer)
+ (lambda (input)
+ (when input
+ (recur-let
+ ((results (funcall parser* input))
+ (output '()))
+ (cond ((empty? results) output)
+ (t
+ (printf "results %s" results)
+ (let* ((first-pair (car results))
+ (rest-pairs (cdr results))
+ (new-parser (->parser (funcall parser-producer (car first-pair))))
+ (new-results (funcall new-parser (cdr first-pair))))
+ (recur rest-pairs (append output new-results)))))))))))
+
+(defun text-parse-return (item)
+ (enclose
+ (item)
+ (lambda (input)
+ (list (cons item input)))))
+
+(defun string-head (s)
+ (if (empty? s) s
+ (substring s 0 1)))
+
+(defun string-tail (s)
+ (if (empty? s) ""
+ (substring s 1)))
+
+(defun /item/ (input)
+ (when/not-empty input
+ (list (cons (string-head input) (string-tail input)))))
+
+(setq monad-text-parse
+ (tbl! :m-return #'text-parse-return
+ :m-bind #'text-parse-bind))
+
+(funcall (lexical-mlet monad-text-parse
+ ((a "a")
+ (b "b"))
+ (m-return (list a b))) "ab")
View
4 monads.el
@@ -413,7 +413,7 @@ This is the most heavy duty form.
current-monad
(lexical-domonad-inner< ,binders ,@body)))))
-(defmacro* lexical-mlet-inner (binders &rest body)
+(defmacro* lexical-mlet-inner (binders &body body)
(cond
((empty? binders) `(progn ,@body))
@@ -425,7 +425,7 @@ This is the most heavy duty form.
(lex-lambda (,symbol)
(lexical-mlet-inner ,(cdr binders) ,@body)))))))
-(defmacro* lexical-mlet (monad binders &rest body)
+(defmacro* lexical-mlet (monad binders &body body)
"LEXICAL-MLET - Chain the operations in BINDERS, regular
lisp style let binding expressions, through the monad MONAD,
finally returning the result of BODY. Lexically bound copies
View
BIN  monads.elc
Binary file not shown
View
51 parser-pres/page-10.el
@@ -2,40 +2,45 @@
;;; consider that :
-(let* ((x 10)
- (y 11))
- (+ x y))
+(mlet* seq-m
+ ((x '(1 2 3))
+ (y '(4 5 6)))
+ (+ x y))
-(let* ((x 10)
- (y (+ x 1)))
- (+ x y))
+ (let* ((x 10)
+ (y 11))
+ (+ x y))
+
+ (let* ((x 10)
+ (y (+ x 1)))
+ (+ x y))
;;; expands to
-(comment
- (funcall
- (lambda (x)
- (funcall (lambda (y) (+ x y)) 11))
- 10)
-)
+ (comment
+ (funcall
+ (lambda (x)
+ (funcall (lambda (y) (+ x y)) 11))
+ 10)
+ )
;;; or, provacatively:
-(comment
-(defun id-bind (v f)
- (funcall f v))
+ (comment
+ (defun id-bind (v f)
+ (funcall f v))
-(id-bind
- 10
- (lambda (x)
- (id-bind
- 11
- (lambda (y)
- (+ x y))))))
+ (id-bind
+ 10
+ (lambda (x)
+ (id-bind
+ 11
+ (lambda (y)
+ (+ x y))))))
;;; or the semantic equivalent.
;;;
;;; parser-let*, then:
-(parser-let*
+ (parser-let*
((a #'parse-a)
(b #'parse-b))
(simple-parser-return
View
6 parser-pres/page-14.el
@@ -122,6 +122,12 @@
(parsed-value (funcall (-irc-message) ":tod.com SEND a b c :rest"))
+((:prefix "tod.com")
+ (:command "SEND")
+ (:params ("a" "b" "c"))
+ (:trailing "rest"))
+
+
;;; WEEEEE
View
4 parser-pres/page-15.el
@@ -29,6 +29,10 @@
;;;
;;; By packing a stack or two into states one could parse with precedence.
+available here:
+
+https://github.com/VincentToups/emacs-utils
+
;;;Controls Home <<< . 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
;;; Index
View
27 partial-symbol-levenstein.el
@@ -0,0 +1,27 @@
+(require 'levenshtein)
+(require 'functional)
+(require 'utils)
+
+(defun partial-levenshtein (s1 s2 delim &optional absent-identical-p)
+ (let* ((parts1 (split-string s1 delim t))
+ (parts2 (split-string s2 delim t))
+ (sorted-by-len (sort* (list parts1 parts2) (decorate-all #'> #'length)))
+ (parts1 (car sorted-by-len))
+ (parts2 (cadr sorted-by-len))
+ (n-parts-2 (length parts2))
+ (parts2
+ (loop for i from 0 below (length parts1)
+ collect
+ (if (< i n-parts-2) (elt parts2 i)
+ (if absent-identical-p (elt parts1 i) "")))))
+ (reduce #'+ (mapcar* #'levenshtein-distance parts1 parts2))))
+
+(defun partial-symbol-levenshtein (s1 s2)
+ (partial-levenshtein (format "%s" s1) (format "%s" s2) "-"))
+
+
+(substring (md5 "skype+ru5tyb!kes") 0 20)"
+"
+
+(+ 5 25 7)0
+
View
2  recur.el
@@ -38,7 +38,7 @@
(comp (par #'simple-expand-recur nil nil nil) #'cadr)
bindings))
(bindings (zip symbols expressions)))
- `(let ,bindings ,@body)))
+ `(,(car form) ,bindings ,@body)))
(defun simple-expand-recur-if (form symbols in-tail loop-sentinal)
"Handle recursion expansion for IF forms."
View
BIN  recur.elc
Binary file not shown
View
4 scripting.el
@@ -56,6 +56,10 @@
(let ((f (cadr (cadr alist-part))))
(funcall f part)))
parts format-alist))))
+
+(defun file-size (file)
+ (alist (file-info file '(("%s" (:size string-to-number)))) :size))
+
(defun file-loc (filename)
(||| lisp-val: (split-string filename "/") reverse cdr reverse "/" 2>join))
View
BIN  scripting.elc
Binary file not shown
View
56 streams.el
@@ -9,33 +9,33 @@
(make-stream :head hd :future future))
(eval-when-compile-also
-(defun single-symbol-list? (item)
- (and (listp item)
- (= (length item) 1)
- (symbolp (car item))))
-(defun binderish? (item)
- (and (listp item)
- (= (length item) 2)
- (symbolp (car item))))
-
-(defun with-form->binder (item)
- (cond ((symbolp item )(list item item))
- ((listp item)
- (cond ((single-symbol-list? item)
- (cons (car item) item))
- ((binderish? item)
- item)
- (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item))))
- (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item))))
-
-(defmacro* later (expr &key (with nil) (with* nil))
- (cond (with
- `(lexical-let ,(mapcar #'with-form->binder with)
- (later ,expr :with* ,with*)))
- (with*
- `(lexical-let* ,(mapcar #'with-form->binder with*)
- (later ,expr)))
- (t `(lambda () ,expr)))))
+ (defun single-symbol-list? (item)
+ (and (listp item)
+ (= (length item) 1)
+ (symbolp (car item))))
+ (defun binderish? (item)
+ (and (listp item)
+ (= (length item) 2)
+ (symbolp (car item))))
+
+ (defun with-form->binder (item)
+ (cond ((symbolp item )(list item item))
+ ((listp item)
+ (cond ((single-symbol-list? item)
+ (cons (car item) item))
+ ((binderish? item)
+ item)
+ (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item))))
+ (t (error "with-forms require symbols, a single symbol list, or a binder-like expression. Got %S." item))))
+
+ (defmacro* later (expr &key (with nil) (with* nil))
+ (cond (with
+ `(lexical-let ,(mapcar #'with-form->binder with)
+ (later ,expr :with* ,with*)))
+ (with*
+ `(lexical-let* ,(mapcar #'with-form->binder with*)
+ (later ,expr)))
+ (t `(lambda () ,expr)))))
(defun scar (stream)
@@ -326,7 +326,7 @@
(later
(stream-map-interleave mf (funcall f))
:with (mf f)))))))
-
+
;; (recur-defun* stream-map-interleave (mf stream)
;; (lexical-let ((mf mf))
View
87 utils.el
@@ -105,14 +105,44 @@
(setq lst (cdr lst)))))
found))))
-(defun* unique (lst &optional (pred #'eq))
- "Returns a new list with only the unique elements in LST under PRED."
- (reverse (foldl
- (lambda (it ac)
- (if (in it ac pred) ac
- (cons it ac)))
- '()
- lst)))
+(defun in-list-by-pred-return (lst pred)
+ "Returns the first item for which PRED is true, else nil."
+ (car (member-if pred lst)))
+
+(defun* replace-when-equal (lst pred trans)
+ (loop for item in lst collect
+ (if (funcall pred item)
+ (funcall trans item)
+ item)))
+
+
+(defun* unique (lst &optional (pred #'eq)
+ (combine (lambda (item acc)
+ acc)))
+ "Returns a new list with only the unique elements in LST under
+PRED. When an element is found more than once in the list, it be
+combined with the recorded element in a non-standard way using COMBINE."
+ (lexical-let ((pred pred)
+ (combine combine))
+ (reverse (foldl
+ (lambda (it seen)
+ (lexical-let ((it it)
+ (seen seen)
+ (pred-prime (lambda (o)
+ (funcall pred it o))))
+ (let ((r (in-list-by-pred-return
+ seen
+ pred-prime)))
+ (if r
+ (replace-when-equal
+ seen
+ pred-prime
+ (lambda (o)
+ (funcall combine it o)))
+ (cons it seen)))))
+ nil
+ lst))))
+
(defun insertf (&rest args)
"Insert with string format string semantics on input."
@@ -2026,6 +2056,45 @@ result. Only works if the difference would fit in 16 bits."
(lambda (b)
(find-file file)))))))
-
+(defun remove-linebreaks-but-preserve-double-lines (s e)
+ (interactive "r")
+ (let ((sigil (md5 (buffer-substring s e))))
+ (narrow-to-region s e)
+ (replace-string (format "\n\n") sigil t s e)
+ (let ((s (point-min))
+ (e (point-max)))
+ (replace-string (format "\n") " " t s e)
+ (replace-string sigil (format "\n\n") t s e))
+ (widen)))
+
+(defun region->markdown->clipboard (s e)
+ (interactive "r")
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (let ((tmp-buffer (current-buffer)))
+ (with-current-buffer buf
+ (shell-command-on-region s e "markdown" tmp-buffer))
+ (kill-region (point-min) (point-max))))))
+
+(defun buffer->markdown->clipboard ()
+ (interactive)
+ (save-excursion
+ (region->markdown->clipboard (point-min) (point-max))))
+
+(defun xor2 (a b)
+ "Exclusive or helper."
+ (if a (not b) b))
+
+(defun xor (&rest args)
+ "Exclusive or."
+ (reduce #'xor2 args))
+
+(defun stringi= (s1 s2)
+ "String equality test, case insensitive."
+ (string= (upcase s1) (upcase s2)))
+
+(defmacro enclose (vars &rest body)
+ "Create a lexical closure over the vars VARS and execute body within it."
+ `(lexical-let ,(mapcar (lambda (var) (list var var)) vars) ,@body))
(provide 'utils)
View
BIN  utils.elc
Binary file not shown
Please sign in to comment.
Something went wrong with that request. Please try again.