Permalink
Browse files

weighted graph monad commit

  • Loading branch information...
1 parent 25df036 commit 664a8db2be74bc9427d8b7082668d4e3b624340c @VincentToups committed Mar 29, 2011
View
@@ -1,6 +1,7 @@
(require 'utils)
(require 'with-stack)
(require 'defn)
+(require 'recur)
(defun file-location (filestr)
@@ -18,4 +19,14 @@
(file-extension "/this/is/a/test/press.txt")
)
+(nthcdr 3 '(a b c d))
+
+(recur-defun* bunch-by (n input &optional (output nil))
+ (if input
+ (let ((bunch (elts input (range n)))
+ (rest (nthcdr n input)))
+ (recur n rest (cons bunch output)))
+ (reverse output)))
+
+
(provide 'advanced-utils)
View
@@ -1,51 +1,36 @@
(require 'utils)
-(setf *animator-funs* (alist>>))
(setf *animator-color-stack* nil)
-
-(defmacro* with-animator (&body body)
- `(labels ,(loop for info in *animator-funs* collect
- (let ((actual-name (car info))
- (local-name (car (cadr info)))
- (arglist (cadr (cadr info)))
- (argsym (gensym "animator-args-")))
- `(,local-name (&rest ,argsym) (apply #',actual-name ,argsym))))
- ,@body))
-(defmacro* defanimatorfun (name arglist docstring &body body)
- (let ((actual-name (internf "animator-%s" name)))
- (setf *animator-funs* (alist>> *animator-funs*
- actual-name (list name arglist)))
- `(defun ,actual-name ,arglist ,docstring (with-animator ,@body))))
(defun start-animator-process ()
(let ((sh (shell "*animator*")))
(comint-send-strings sh "animator")
(setq *animator* sh)))
(start-animator-process)
-(defanimatorfun send (&rest strings)
+(defun animator-send (&rest strings)
(apply #'comint-send-strings *animator* strings))
-(defanimatorfun flush ()
+(defun animator-flush ()
(comint-send-strings *animator* "flush"))
-(defanimatorfun frame ()
+(defun animator-frame ()
(comint-send-strings *animator* "frame"))
-(defanimatorfun color (cc)
+(defun animator-color (cc)
(if (listp cc)
(let* ((s (format "%s" cc))
(n (length s)))
(animator-send (concat "color " (substring s 1 (- n 1)))))
(animator-send (format "color %s" cc))))
-(defanimatorfun push-color (cc)
+(defun animator-push-color (cc)
(push cc *animator-color-stack*)
(if (listp cc)
(let* ((s (format "%s" cc))
(n (length s)))
(animator-send (concat "color " (substring s 1 (- n 1)))))
(animator-send (format "color %s" cc))))
-(defanimatorfun pop-color ()
+(defun animator-pop-color ()
(let ((clr (pop *animator-color-stack*))
(top (car *animator-color-stack*)))
(if top (animator-color top)
@@ -64,50 +49,111 @@
(defmacro* with-flush/frame (&body body)
`(progn (animator-frame) ,@body (animator-flush)))
-(defanimatorfun dot (x y)
+(defun animator-dot (x y)
(comint-send-strings *animator*
(format "dot %f %f" x y)))
-(defanimatorfun dots (pairs)
+(defun animator-dots (pairs)
(loop for pair in pairs do
(apply #'animator-dot pair)))
-(defanimatorfun line (x1 y1 x2 y2)
+(defun animator-line (x1 y1 x2 y2)
(animator-send (format "line %f %f %f %f" x1 y1 x2 y2)))
-(defanimatorfun disjoint-lines (&rest lines)
+(defun animator-disjoint-lines (&rest lines)
(loop for line in lines do
(apply animator-line line)))
-(defanimatorfun connected-lines (&rest args)
+(defun animator-connected-lines (&rest args)
(let ((args (flatten args)))
(animator-send
(concat "lines "
(foldl (lambda (it ac) (concat ac (format " %f" it)))
""
args)))))
-(defanimatorfun poly (&rest args)
+(defun animator-poly (&rest args)
(let ((args (flatten args)))
(animator-send
(concat "poly "
(foldl (lambda (it ac) (concat ac (format " %f" it)))
""
args)))))
-(defanimatorfun circle (x y r &optional verts)
+(defun animator-circle (x y r &optional verts)
(let ((verts (if verts verts 25)))
(animator-send (format "circle %f %f %f %f" x y r verts))))
-(defanimatorfun filled-circle (x y r &optional verts)
+(defun animator-filled-circle (x y r &optional verts)
(let ((verts (if verts verts 25)))
(animator-send (format "fillcircle %f %f %f %f" x y r verts))))
-(defanimatorfun text (x y text &optional alignment)
+(defun animator-text (x y text &optional alignment)
(if alignment
(animator-send (format "text %s %f %f \"%s\"" alignment x y text))
(animator-send (format "text %f %f \"%s\"" x y text))))
+(defun animator-dup ()
+ (animator-send "push"))
+
+(defun animator-pop ()
+ (animator-send "pop"))
+
+(defun animator-ident ()
+ (animator-send "ident"))
+
+(defun animator-shift (x y)
+ (animator-send (format "shift %f %f" x y)))
+
+(defun animator-rotate (degrees)
+ (animator-send (format "rotate %f" degrees)))
+
+(defun animator-scale (x &optional y)
+ (let ((y (if y y x)))
+ (animator-send (format "scale %f %f" x y))))
+
+(defun animator-viewport (left bottom w h)
+ (animator-send (format "viewport %f %f %f %f" left bottom w h)))
+
+(defun create-animator-format-string (name-string args)
+ (loop for i from 1 to (length args) do
+ (setq name-string (concat name-string " %f")))
+ name-string)
+
+(defmacro* def-numeric-animator-primitive (name &optional doc &rest arg-names)
+ (let ((interface-name (internf "animator-%s" name))
+ (name-string (format "%s" name))
+ (doc (if (stringp doc) doc nil))
+ (arg-names (if (stringp doc) arg-names
+ (cons doc arg-names))))
+ `(defun ,interface-name ,arg-names ,doc
+ (animator-send (format ,(create-animator-format-string name-string arg-names)
+ ,@arg-names)))))
+
+(defmacro* def-numeric-animator-primitive-alt-name (interface-name name &optional doc &rest arg-names)
+ (let ((name-string (format "%s" name))
+ (doc (if (stringp doc) doc nil))
+ (arg-names (if (stringp doc) arg-names
+ (cons doc arg-names))))
+ `(defun ,interface-name ,arg-names ,doc
+ (animator-send (format ,(create-animator-format-string name-string arg-names)
+ ,@arg-names)))))
+
+
+(def-numeric-animator-primitive thick "Set animator line thickness"
+ thickness)
+
+(def-numeric-animator-primitive alpha "Set animator transparency." alpha)
+
+(def-numeric-animator-primitive arrow "Draw an arrow pointing towards X2 Y2"
+ x1 y1 x2 x2)
+
+(def-numeric-animator-primitive-alt-name fill-rect fillrect "Fill an animator rectangle with the current color." x y w h)
+
+(def-numeric-animator-primitive rect "Fill an animator rectangle with the current color." x y w h)
+
+(with-flush/frame (animator-rect 0 0 .25 .25))
+
@@ -133,5 +179,4 @@
(color "green"))
)
-
(provide 'animator)
View
Binary file not shown.
View
@@ -112,7 +112,7 @@
(|||- {qtn} call))))
(defstackword loop-until-char
- (|||- '(char-at-point->string string=) curry loop-until))
+ (|||- '(char-at-point->string 2>string=) curry loop-until))
(defstackword forward
(forward-char))
@@ -232,7 +232,7 @@
(defstackword kill (|||- 1>move-kill drop))
(setq micro-stack-map
- (alist>>
+ (tbl!
'm 'move ; generic movement. pops an item from the stack, then moves appropriately
'k 'kill ; generic move-and-kil, pops and item of the stack, marks, moves, and kill-region's
'l 'line ; specify that a number indicates a number of lines
@@ -286,7 +286,7 @@
(loop for el in code append
(cond
((symbolp el)
- (let ((trans (alist micro-stack-map el)))
+ (let ((trans (tbl micro-stack-map el)))
(if trans (list trans) (error "Unknown microstack word."))))
((listp el)
(list 'lisp-val: `(quote ,el)))
@@ -304,5 +304,4 @@
(interactive "s")
(let* ((code (parse-microstack str))
(code (translate-microstack code)))
- (print code)
(do-microstack-parsed-translated code)))
View
Binary file not shown.
View
@@ -396,6 +396,7 @@
(cons x y)))
(defun parse-string (parser string)
+ (print (funcall parser (->in string)))
(car (car (funcall parser (->in string)))))
(defun parse-sequence (parser sequence)
@@ -407,7 +408,7 @@
(rest (input->string (cdr (car pr)))))
(if (or (not result)
(not rest)) nil
- (list result (input->string rest)))))
+ (list result rest))))
(defun =lit-sym (sym)
(=satisfies (f-and
View
Binary file not shown.
View
@@ -0,0 +1,9 @@
+(provide 'monad-transformers)
+(require 'monads)
+(require 'utils)
+
+(defun sequence-t (inner-monad)
+ (alist
+ :m-bind (lambda (v f)
+ (with-monad inner-monad
+ (mapcat
Oops, something went wrong.

0 comments on commit 664a8db

Please sign in to comment.