Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

microstack generic motion

  • Loading branch information...
commit 7151130979885d679dee9a25e23de8d22f5b0aa7 1 parent e2e0cc4
@VincentToups authored
View
21 classy.el
@@ -0,0 +1,21 @@
+(provide 'classy)
+(require 'multimethods)
+
+(defvar *classy-weak-table* (make-hash-table :test 'eq :weakness t) "Classy table to distinguish between lists and instances.")
+
+(defun classy-alist>> (&rest args)
+ (let ((o (apply #'alist>> args)))
+ (alist! o :--classy-tag (gensym "classy-tag-"))
+ (alist! o :--class :thing)
+ (setf (gethash (alist o :--classy-tag) *classy-weak-table*) t)
+ o))
+
+(let ((cc (classy-alist>> :x 10 :y 11)))
+ (gethash (alist cc :--classy-tag) *classy-weak-table*)
+ (alist cc :--classy-tag))
+
+(defun classy-objectp (object)
+ (and (listp object)
+ (gethash (alist object :--classy-tag) *classy-weak-table*)))
+
+k
View
137 microstack.el
@@ -2,8 +2,11 @@
(require 'functional)
(require 'with-stack)
(require 'stack-words)
+(require 'multi-methods)
(provide 'microstack)
+
+
(defunc =microstack-symbol ()
"Parser for a microstack symbol, or a space (no-op)."
(=let* [_ (=or (letter)
@@ -50,8 +53,8 @@
(defun microstack-parser ()
"Parser for the microstack language."
(zero-or-more (=or
- (=microstack-symbol)
(=number)
+ (=microstack-symbol)
(=microstack-string)
(=microstack-quote))))
@@ -121,22 +124,124 @@
(rest (pop *stack*)))
(push (apply #'format (cons fmtstr rest)) *stack*)))
-(defstackword generic-move
- (let ((arg (pop *stack*)))
- (cond
- ((numberp arg) (|||- {arg} word))
- ((
+(defun move-dispatcher (object)
+ "Dispatch for generic motion."
+ (cond ((numberp object) :char)
+ ((listp object) (car object))
+ (t nil)))
+
+(defmulti move #'move-dispatcher "A generic motion function.")
+
+(defunmethod move :char (movement)
+ (let ((n (if
+ (listp movement) (cadr movement)
+ movement)))
+ (forward-char n)))
+
+(defunmethod move :word (movement)
+ (forward-word (cadr movement)))
+
+(defunmethod move :line (movement)
+ (beginning-of-line)
+ (forward-line (cadr movement)))
+
+(defunmethod move :paragraph (movement)
+ (forward-paragraph (cadr movement)))
+
+(defstackword word
+ (|||- :word swap 2>list))
+
+(defstackword paragraph
+ (|||- :paragraph swap 2>list))
+
+(defstackword page
+ (|||- :page swap 2>list))
+
+(defstackword line
+ (|||- :line swap 2>list))
+
+(defstackword char
+ (|||- :char swap 2>list))
+
+(defstackword sym
+ (|||- :symbol swap 2>list))
+
+(defstackword s-expression
+ (|||- :sexp swap 2>list))
+
+(defstackword make-quantity-of
+ (|||- 1>make-keyword swap 2>list))
+
+($ :char derives-from :movement-type)
+($ :movement-type-with-extent
+ derives-from :movement-type)
+($ :word derives-from :movement-type-with-extent)
+($ :paragraph derives-from :movement-type-with-extent)
+($ :line derives-from :movement-type-with-extent)
+
+
+(defmulti move-kill #'move-dispatcher "Generic deletion method.")
+
+(defmulti pre-delete-movement (function move-dispatcher) "Handle movement before delete.")
+(defunmethod pre-delete-movement :movement-type (movement)
+ nil
+ )
+
+(defmulti post-delete-movement (function move-dispatcher) "Handle movement before delete.")
+(defunmethod post-delete-movement :movement-type (movement)
+ nil
+ )
+
+(defun bounds-of-thing-at-point-kw (kw)
+ (bounds-of-thing-at-point (keyword->symbol kw)))
+
+(defunmethod pre-delete-movement :movement-type-with-extent (movement)
+ (let* ((thing-bounds (bounds-of-thing-at-point-kw (car movement)))
+ (start (car thing-bounds))
+ (stop (cdr thing-bounds)))
+ (cond ((positive? (cadr movement)) (goto-char start))
+ ((negative? (cadr movement)) (goto-char stop))
+ ((zero? (cadr movement)) nil))))
+
+(defunmethod post-delete-movement :movement-type-with-extent (movement)
+ (let* ((thing-bounds (bounds-of-thing-at-point-kw (car movement)))
+ (start (car thing-bounds))
+ (stop (cdr thing-bounds)))
+ (cond ((positive? (cadr movement)) (goto-char stop))
+ ((negative? (cadr movement)) (goto-char start))
+ ((zero? (cadr movement)) nil))))
+
+
+(defun point-in-word? ()
+ (save-excursion (let ((pt (point)))
+ (backward-word) (forward-word)
+ (!= pt (point)))))
+
+(defunmethod move-kill :movement-type (movement)
+ (let (p1 p2)
+ (pre-delete-movement movement)
+ (setq p1 (point))
+ (move movement)
+ (post-delete-movement movement)
+ (setq p2 (point))
+ (kill-region p1 p2)))
+
+
+
+(defstackword move (|||- 1>move drop))
+(defstackword kill (|||- 1>move-kill drop))
(setq micro-stack-map
(alist>>
- 'b 'backward ; move the point backward once
- 'B '1>backward-char ; move the point backward n times, pop n from the stack
- 'f 'forward ; move the point forward once
- 'F '1>forward-char ; move the point forward n times, pop n from the stack
- 'd 'delete-forward0 ; delete forward once
- 'D 'delete-forward ; delete forward n times, pop n from the stack
- 'k 'delete-backward0 ; delete backward once
- 'K 'delete-backward ; delete backward n times, remove n from the stack
+ '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
+ 'w 'word ; specify that a number indicates a number of words
+ 'y 'sym ; specify that a number indicates a number of symbols
+ 'p 'paragraph ; specify that a number indicates a number of paragraphs
+ 'P 'page ; specify that a number indicates a number of pages
+ 'e 's-expression ; specify that a number indicates a number of s-expressions
+ 'G 'make-quantity-of ; take a string and a number and create a general quantity 4"sentence"G -> (:sentence 4)
'q 'microstack->quotation ; convert a STRING to a microstack compiled quotation, "..."q is eq to [...]
'Q 'string->quotation ;push the stack word represented by string onto the stack to be called later
'! 'call ; call a quotation/stack word
@@ -159,6 +264,7 @@
's '1>search-forward ; search forward for the string on the stack, which is popped
'S '1>search-forward-regexp ; search forward for the regex on the stack, which is popped
'c 'concat ; concat two strings
+ 'o 'rot
(intern ",") 'print-stack ; print the stack
(intern ":") 'dup ; dup
(intern "$") 'swap ; swap the top two stack elements
@@ -175,8 +281,6 @@
))
-
-
(defun translate-microstack (code)
"Translate the single character symbols to their stack words. Process special microstack behavior words."
(loop for el in code append
@@ -202,4 +306,3 @@
(code (translate-microstack code)))
(print code)
(do-microstack-parsed-translated code)))
-
View
82 microstack.md
@@ -24,18 +24,19 @@ What does it look like?
Will prompt you to enter a string. If you type
- 4D"test"i
+ 4k"test"i
You will find that emacs has deleted the four characters ahead of your
position in the buffer, and then inserted the text "test".
If you enter instead
- [k]10N
+ [-1k]10N
-You'll find emacs has deleted the last ten characters.
+You'll find emacs has deleted the last ten characters. You might have instead just said
+directly -10k.
- "dogs and cats"s4D"bees"i
+ "dogs and cats"s4k"bees"i
Will jump forward to the first location of "dogs and cats" after the
cursor, delete dogs, and replace it with bees.
@@ -82,6 +83,53 @@ The idea is to provide the most useful/common stack language words for
text manipulation as single character operands, for brevity, while
allowing the full power of the emacs stack language.
+Generic Motion and Deletion
+---------------------------
+
+If you've been following this repository, you may have noticed a large
+change in the stack words for motion. Whereas before there was an
+attempt to provide specific words for all sorts of motion and deletion
+cases, I've rewritten this library (using my implementation of
+[multimethods](https://github.com/VincentToups/emacs-utils/blob/master/multi-methods.md)) to provide generic motion and deletion words. Instead
+of a variety of words we now have only `m` for "move" and `k` for `kill`.
+
+Both take their motion from the top of the stack. If the stack holds
+a number, then they simply move or delete characters, forward for
+positive numbers and backwards for negative ones.
+
+If you want to delete or move by some other method, you must specify
+this by decorating the number on the stack with descriptor words. EG:
+
+ 4m
+
+Moves forward 4 characters.
+
+ 4wm
+
+Moves forward 4 words (using foward-word).
+
+ 4pm
+
+Moves four paragraphs.
+
+ 4em
+
+Four s-expressions. Etc. See the documentation below for all modifiers.
+
+The modifiers also work with the kill word, so
+
+ -4wk
+
+Deletes four words backward, including the current word. Emacs has
+lots of `forward-<something>` words, and there aren't really enough
+keys to support them all, so you can call any motion type using the G
+word, which takes its motion from a string.
+
+ -4"sentence"Gk
+
+Kills the last four sentences, including the current one.
+
+
How can I learn more about this amazing invention??
---------------------------------------------------
@@ -90,20 +138,21 @@ this repository will tell you anything else you might want to know.
Both have in-emacs documentation for most functions/macros. So far
the language supports the following operands
- 'b 'backward ; move the point backward once
- 'B '1>backward-char ; move the point backward n times, pop n from the stack
- 'f 'forward ; move the point forward once
- 'F '1>forward-char ; move the point forward n times, pop n from the stack
- 'd 'delete-forward0 ; delete forward once
- 'D 'delete-forward ; delete forward n times, pop n from the stack
- 'k 'delete-backward0 ; delete backward once
- 'K 'delete-backward ; delete backward n times, remove n from the stack
+ '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
+ 'w 'word ; specify that a number indicates a number of words
+ 'y 'sym ; specify that a number indicates a number of symbols
+ 'p 'paragraph ; specify that a number indicates a number of paragraphs
+ 'P 'page ; specify that a number indicates a number of pages
+ 'e 's-expression ; specify that a number indicates a number of s-expressions
+ 'G 'make-quantity-of ; take a string and a number and create a general quantity 4"sentence"G -> (:sentence 4)
'q 'microstack->quotation ; convert a STRING to a microstack compiled quotation, "..."q is eq to [...]
'Q 'string->quotation ;push the stack word represented by string onto the stack to be called later
'! 'call ; call a quotation/stack word
'? 'if ; if
'+ '+ ; plus
- '- '- ; -
+ '- '- ; -, note that - before a number without a space will be read as a negative number. delimite - with spaces to indicate the operator.
't 't ; push t
'_ 'nil ; push nil
'm '0>push-mark ; mark the current point as the mark
@@ -120,6 +169,7 @@ the language supports the following operands
's '1>search-forward ; search forward for the string on the stack, which is popped
'S '1>search-forward-regexp ; search forward for the regex on the stack, which is popped
'c 'concat ; concat two strings
+ 'o 'rot
(intern ",") 'print-stack ; print the stack
(intern ":") 'dup ; dup
(intern "$") 'swap ; swap the top two stack elements
@@ -128,12 +178,14 @@ the language supports the following operands
(intern ".") 'print ; print the top of the stack, pop it
(intern "%") 'format ; lst format-string format; calls format with the string format-string and lst as rest args
(intern "|") 'compose ; compose two quotations
- (intern "/") 'curry ; curry the value on the stack into the quotation below it.
- 'U 'loop-until ; qt pred loop-until ; loop qt until pred is true
+ (intern "^") 'curry ; curry the value on the stack into the quotation below it.
+ 'U 'loop-until ; qt pred loop-until ; loop qt until pred is true
+ 'u 'loop-until-char ; qt char loop-until-char; loop qt until char is beneath the cursor.
'W 'loop-while ; qt pred loop-while ; loop qt while pred is true
'i 'insert ; insert the top of the stack as text into the buffer
+
Obviously I'm going to add more operands as I use the library and determine what I wish to do.
Hope someone out there finds this interesting!
View
79 multi-methods.el
@@ -11,6 +11,10 @@
"generates the symbol for the dispatch function for METHOD"
(internf "--%s-dispatcher" method))
+(defun mk-default-method-name (method)
+ "generates the symbol for the default method for METHOD"
+ (internf "--%s-default-method" method))
+
(defun make-keyword-accessor (kw)
"Creates an accessor for tables looking for KW"
(lexical-let ((kw kw))
@@ -31,33 +35,43 @@
((functionp object) t)
((and (listp object)
(= 2 (length object))
- (functionp (cadr object))))
+ (eq (car object) 'function)))
+ ;(functionp (cadr object)))) ;
(t nil)))
(defmacro* defmulti (name dispatch &optional (doc "") (hierarchy-name '*multi-method-heirarchy*))
"Define a multi-method NAME with dispatch function DISPATCH. DEFUNMULTI defines specific instances of the method."
(let ((table-name (mk-dispatch-table-name name))
+ (default-method-name (mk-default-method-name name))
(dispatch-name (mk-dispatch-function-name name))
(args-name (gensymf "multi-%s-args" name))
(internal-name (gensymf "multi-%s-holder" name))
(temp (gensym)))
`(progn
+ (defvar ,default-method-name nil)
(defvar ,table-name (alist>>) ,(format "dispatch-table for %s" name))
(setq ,table-name (alist>>))
(let ((,temp ,dispatch))
(defvar ,dispatch-name ,temp ,(format "dispatch-function for %s" name))
(setq ,dispatch-name ,temp)
(unless (functionp ,dispatch-name)
- (print (format "Creating a dispatch function for %S." ,dispatch-name))
+ (print (format "Creating a dispatch function for %S. You may need to define %S before declaring the multimethod if you don't mean to use table-based dispatch." ,dispatch-name ,dispatch-name))
(setq ,dispatch-name (make-keyword-accessor ,dispatch-name))))
(defun ,name (&rest ,args-name)
,doc
(let* ((*multi-method-heirarchy* ,hierarchy-name)
- (,internal-name (isa-dispatch (apply ,dispatch-name ,args-name) ,table-name (make-resolve-by-table (alist *preferred-dispatch-table* ',name) ',name))))
+ (,internal-name (isa-dispatch (apply ,dispatch-name ,args-name) ,table-name (make-resolve-by-table (alist *preferred-dispatch-table* ',name) ',name ) ,default-method-name)))
(if ,internal-name (apply ,internal-name ,args-name)
(error (format ,(format "No known method for args %%S for multimethod %s.\n Dispatch value is: %%S" name) ,args-name (apply ,dispatch-name ,args-name)))))))))
+(defmacro* defunmethod-default (name arglist &body body)
+ `(progn
+ (setq ,(mk-default-method-name name)
+ (lambda ,arglist
+ ,@body))
+ ',name))
+
(defmacro* defunmethod (name value arglist &body body)
"Define a method using DEFUN syntax for the dispatch value VALUE."
(let ((g (gensym))
@@ -125,6 +139,15 @@
(apply #'derive2 (cdr args))))
(t "Derive takes 2 or 3 arguments. More or less were given.")))
+(defun* derives-from (child parent &optional (h *multi-method-heirarchy*))
+ (let ((*multi-method-heirarchy* h))
+ (derive2 parent child)))
+
+(defun derive-from (children parent &optional (h *multi-method-heirarchy*))
+ (let ((*multi-method-heirarchy* h))
+ (loop for child across (coerce children 'vector) do
+ (derives-from child parent h))))
+
(defun mm-parents (child)
"Get the PARENTS of CHILD from the hierachy in the dynamic scope."
(let ((parents (alist *multi-method-heirarchy* :up)))
@@ -165,6 +188,24 @@
(setq done t))))
descendants))
+(defun get-method (name dispatch-value)
+ "Get the multimethod of kind NAME that is the nearest match for the DISPATCH-VALUE."
+ (let* ((method-table-name (mk-dispatch-table-name name))
+ (method-table (eval method-table-name)))
+ (isa-dispatch dispatch-value method-table (make-resolve-by-table name))))
+
+(defun get-method-funcall (name dispatch-value &rest args)
+ "Get the method associated with NAME and DISPATCH-VALUE and call it on ARGS."
+ (let ((m (get-method name dispatch-value)))
+ (if m (apply m args)
+ (error "get-method-funcall: No method for %s with dispatch value %S." name dispatch-value))))
+
+(defun get-method-funcall (name dispatch-value args)
+ "Get the method associated with NAME and DISPATCH-VALUE and call it on ARGS, a list."
+ (let ((m (get-method name dispatch-value)))
+ (if m (apply m args)
+ (error "get-method-funcall: No method for %s with dispatch value %S." name dispatch-value))))
+
; declare some testing hierarchy
(derive :thing :parseable)
(derive :thing :number)
@@ -242,22 +283,24 @@
(list rank (alist (list p1 p2) resolution))
(error "Method dispatch ambiguity for %s unresolved (%S vs %S)." method-name (car p1) (car p2))))))
-(defun isa-dispatch (object alist resolver)
+(defun* isa-dispatch (object alist resolver &optional (default-method nil))
"Dispatch from an alist table based on ISA? matches. More specific matches are preferred over less, and ambiguous matches will be resolved by the function resolver."
- (cadr (cadr (foldl
- (lambda (alist-pair best-so-far)
- (let ((rank (isa? object (car alist-pair))))
- (cond
- ((not rank) best-so-far)
- ((not best-so-far) (list rank alist-pair))
- ((< rank (car best-so-far))
- (list rank alist-pair))
- ((> rank (car best-so-far)) best-so-far)
- ((= rank (car best-so-far))
- (if rank
- (funcall resolver object rank alist-pair (cadr best-so-far)) nil)))))
- nil
- alist))))
+ (let-if method (cadr (cadr (foldl
+ (lambda (alist-pair best-so-far)
+ (let ((rank (isa? object (car alist-pair))))
+ (cond
+ ((not rank) best-so-far)
+ ((not best-so-far) (list rank alist-pair))
+ ((< rank (car best-so-far))
+ (list rank alist-pair))
+ ((> rank (car best-so-far)) best-so-far)
+ ((= rank (car best-so-far))
+ (if rank
+ (funcall resolver object rank alist-pair (cadr best-so-far)) nil)))))
+ nil
+ alist)))
+ method
+ default-method))
(dont-do
;example
View
24 utils.el
@@ -1684,6 +1684,7 @@
(shf "nautilus %s &" s))
(defun unfold (pred f gen init)
+ "The unfold combinator. Call GEN repeatedly on its result (starting with init) and collect the results of F on that value until PRED on that value is nil."
(let ((output nil))
(loop while (funcall pred init) do
(push (funcall f init) output)
@@ -1691,6 +1692,7 @@
output))
(defun unfold-mem (pred f gen init)
+ "The unfold combinator. Call GEN repeatedly on its result (starting with init) and collect the results of F on that value until PRED all previous values of F on value is nil."
(let ((output nil))
(loop while (apply pred output) do
(push (funcall f init) output)
@@ -1701,10 +1703,32 @@
(defconst phi 1.61803399 "The golden ratio")
(defun gensymf (&rest args)
+ "Like gensym with format semantics on arguments."
(gensym (apply #'format args)))
(defun* for-work-monitor (&optional (val 100))
+ "resize the text on screen for work monitor."
(interactive)
(set-face-attribute 'default nil :height val))
+(defun zero? (n)
+ "Is N zero?"
+ (= n 0))
+
+(defun positive? (n)
+ "Is n positive?"
+ (and (not (zero? n))
+ (= (abs n) n)))
+
+(defun negative? (n)
+ "Is n negative?"
+ (and (not (zero? n))
+ (not (positive? n))))
+
+(defun keyword->symbol (kw)
+ "Convert a keyword to a regular symbol."
+ (intern (substring (format "%s" kw) 1)))
+
+
+
(provide 'utils)
View
BIN  utils.elc
Binary file not shown
Please sign in to comment.
Something went wrong with that request. Please try again.