Browse files

defn fixes, more stack language

  • Loading branch information...
1 parent fce4787 commit ab9dc2431ee02d0268187ea813f847ed95d60360 @VincentToups committed Jun 5, 2010
Showing with 205 additions and 28 deletions.
  1. +2 −0 README.md
  2. +102 −0 chemistry.el
  3. +10 −5 defn.el
  4. +5 −1 utils.el
  5. +61 −21 with-stack.el
  6. +25 −1 with-stack.md
View
2 README.md
@@ -221,3 +221,5 @@ Most useful in the utils package may be a pair of functions for creating and man
(tbl! :x 10 :y 11) ; creates a hash table with keys :x, :y and associated values
(tbl a-table :x) ; returns the value at key :x
+Update 5 June 2010
+* Corrected a bug in defn expansion with recur.
View
102 chemistry.el
@@ -0,0 +1,102 @@
+(require 'with-stack)
+(require 'eperiodic)
+
+(defun element-name (element)
+ (||| 'name {element} 2>assoc 1>cdr))
+(defun element-symbol (element)
+ (||| 'symbol {element} 2>assoc 1>cdr))
+(defun element-name (element) (||| 'name {element} 2>assoc 1>cdr))
+(defun element-symbol (element) (||| 'symbol {element} 2>assoc 1>cdr))
+(defun element-atomic-mass (element)
+ (||| 'atomic-mass {element} 2>assoc 1>cdr))
+(defun element-density (element) (||| 'density {element} 2>assoc 1>cdr))
+(defun element-melting-point (element)
+ (||| 'melting-point {element} 2>assoc 1>cdr))
+(defun element-boiling-point (element)
+ (||| 'boiling-point {element} 2>assoc 1>cdr))
+(defun element-atomic-radius (element)
+ (||| 'atomic-radius {element} 2>assoc 1>cdr))
+(defun element-covalent-radius (element)
+ (||| 'covalent-radius {element} 2>assoc 1>cdr))
+(defun element-ionic-radius (element)
+ (||| 'ionic-radius {element} 2>assoc 1>cdr))
+(defun element-atomic-volume (element)
+ (||| 'atomic-volume {element} 2>assoc 1>cdr))
+(defun element-specific-heat (element)
+ (||| 'specific-heat {element} 2>assoc 1>cdr))
+(defun element-fusion-heat (element)
+ (||| 'fusion-heat {element} 2>assoc 1>cdr))
+(defun element-evaporation-heat (element)
+ (||| 'evaporation-heat {element} 2>assoc 1>cdr))
+(defun element-thermal-conductivity (element)
+ (||| 'thermal-conductivity {element} 2>assoc 1>cdr))
+(defun element-debye-temperature (element)
+ (||| 'debye-temperature {element} 2>assoc 1>cdr))
+(defun element-pauling-negativity-number (element)
+ (||| 'pauling-negativity-number {element} 2>assoc 1>cdr))
+(defun element-first-ionization-energy (element)
+ (||| 'first-ionization-energy {element} 2>assoc 1>cdr))
+(defun element-oxidation-states (element)
+ (||| 'oxidation-states {element} 2>assoc 1>cdr))
+(defun element-lattice-structure (element)
+ (||| 'lattice-structure {element} 2>assoc 1>cdr))
+(defun element-lattice-constant (element)
+ (||| 'lattice-constant {element} 2>assoc 1>cdr))
+(defun element-lattice-c/a-ratio (element)
+ (||| 'lattice-c/a-ratio {element} 2>assoc 1>cdr))
+(defun element-appearance (element)
+ (||| 'appearance {element} 2>assoc 1>cdr))
+(defun element-discovery-date (element)
+ (||| 'discovery-date {element} 2>assoc 1>cdr))
+(defun element-discovered-by (element)
+ (||| 'discovered-by {element} 2>assoc 1>cdr))
+(defun element-named-after (element)
+ (||| 'named-after {element} 2>assoc 1>cdr))
+
+(defn get-element-by-name
+ ([name [element & rest :as elements]]
+ (cond
+ ((or (string= (upcase name) (upcase (element-name element)))
+ (string= (upcase name) (upcase (element-symbol element))))
+ element)
+ ((not elements) nil)
+ (t (recur name rest))))
+ ([name]
+ (get-element-by-name name eperiodic-element-properties)))
+
+(get-element-by-name "Helium" eperiodic-element-properties)
+(get-element-by-name "He")
+
+(defun less-electronegative-than (a b)
+ (let ((en1 (read (element-pauling-negativity-number a)))
+ (en2 (read (element-pauling-negativity-number b))))
+ (cond ((and (numberp en1)
+ (numberp en2))
+ (< en1 en2))
+ ((and (symbolp en1)
+ (numberp en2))
+ nil)
+ ((and (numberp en1)
+ (symbolp en2))
+ t)
+ ((and (symbolp en1)
+ (symbolp en2))
+ nil))))
+
+(defun more-electronegative-than (a b)
+ (let ((en1 (read (element-pauling-negativity-number a)))
+ (en2 (read (element-pauling-negativity-number b))))
+ (cond ((and (numberp en1)
+ (numberp en2))
+ (> en1 en2))
+ ((and (symbolp en1)
+ (numberp en2))
+ nil)
+ ((and (numberp en1)
+ (symbolp en2))
+ t)
+ ((and (symbolp en1)
+ (symbolp en2))
+ nil))))
+
+(setf chemical-names (||| {eperiodic-element-properties} '(1>element-symbol) map))
View
15 defn.el
@@ -447,12 +447,17 @@
(eq (car form) 'progn)))
(defun expand-recur-cond-pair (cond-pair parent-is-tale loop-sentinal binding-forms)
`(,(car cond-pair)
- ,@(expand-recur (cdr cond-pair) parent-is-tale loop-sentinal binding-forms)))
+ ,@(cdr (expand-recur `(progn ,@(cdr cond-pair)) parent-is-tale loop-sentinal binding-forms))))
+;; (defun expand-recur-recur (form parent-is-tale loop-sentinal binding-forms)
+;; `(progn
+;; (setq ,loop-sentinal t)
+;; (dsetq ,@(loop for b in (coerce binding-forms 'list) and v in (cdr form)
+;; collect b and collect v))))
(defun expand-recur-recur (form parent-is-tale loop-sentinal binding-forms)
`(progn
(setq ,loop-sentinal t)
- (dsetq ,@(loop for b in (coerce binding-forms 'list) and v in (cdr form)
- collect b and collect v))))
+ (dsetq ,@binding-forms (list ,@(cdr form)))))
+
(defun let-likep (form)
(and (listp form)
@@ -483,7 +488,7 @@
(cddr mxform))))
((condp mxform)
`(cond
- ,@(map
+ ,@(mapcar
(lambda (cond-pair)
(expand-recur-cond-pair
cond-pair
@@ -493,7 +498,7 @@
(cdr mxform))))
((casep mxform)
`(case ,(cadr mxform)
- ,@(map
+ ,@(mapcar
(lambda (cond-pair)
(expand-recur-cond-pair
cond-pair
View
6 utils.el
@@ -508,6 +508,7 @@
(defun ff/this-text (filename txt)
(with-current-buffer (find-file filename)
+ (goto-char (point-min))
(word-search-forward txt)))
(defun pwd->kill-ring ()
@@ -646,7 +647,7 @@
forms-to-apply)
,name))
-(defun* ok-today? (&optional (p .4))
+(defun* ok-today? (&optional (p .3))
(> (/ (read (concat "#x" (substring (md5 (calendar-iso-date-string)) 0 2))) 255.0) p))
(defmacro & (fs &rest args)
@@ -707,4 +708,7 @@
(assert (listp ll) "vector->list needs a list input.")
(coerce ll 'vector))
+(defun functional-sort (list pred)
+ (sort (copy-sequence list) pred))
+
(provide 'utils)
View
82 with-stack.el
@@ -40,7 +40,8 @@
(let ((*stack* code)
(*retain-stack* nil))
(funcall (car (tbl *stack-words* item)))
- (setf code *stack*)))
+ (setf code *stack*))
+ nil)
(defun handle-stack-word (item)
(if (stackword-immediatep item) (handle-immediate-stackword item)
@@ -77,45 +78,62 @@
`(,s (pop *stack*)))
(push (,sym ,@(reverse temp-syms)) *stack*))))))
+(defun stack-interpolationp (item)
+ (let* ((s (format "%s" item))
+ (n (length s)))
+ (and (string= (substring s 0 1) "{")
+ (string= (substring s (- n 1) n) "}"))))
+
+(defun stack-get-interpolation-symbol (item)
+ (let* ((s (format "%s" item))
+ (n (length s)))
+ (intern (substring s 1 (- n 1)))))
+
+(defun handle-stack-interpolation (item)
+ `(push ,(stack-get-interpolation-symbol item) *stack*))
+
(defun handle-stack-symbol (item)
(cond
((or (eq item 't) (eq item t)) `(push t *stack*))
((stack-wordp item) (handle-stack-word item))
((stack-emacs-callp item) (handle-emacs-call item))
+ ((stack-interpolationp item) (handle-stack-interpolation item))
(t (error (format "stack: Can't figure out how to compile %s." item)))))
(defmacro* with-stack- (&body code)
`(progn
- ,@(loop while code collect
- (let ((item (car code)))
- (setf code (cdr code))
- (cond
- ((eq item nil)
- `(push nil *stack*))
- ((stack-atomp item)
- (handle-stack-atom item))
- ((symbolp item)
- (handle-stack-symbol item)))))))
+ ,@(filter #'identity (loop while code collect
+ (let ((item (car code)))
+ (setf code (cdr code))
+ (cond
+ ((eq item nil)
+ `(push nil *stack*))
+ ((stack-atomp item)
+ (handle-stack-atom item))
+ ((symbolp item)
+ (handle-stack-symbol item))))))))
(defmacro* with-stack (&body code)
`(let ((*stack* nil)
(*retain-stack* nil))
- ,@(loop while code collect
- (let ((item (car code)))
- (setf code (cdr code))
- (cond
- ((eq item nil)
- `(push nil *stack*))
- ((stack-atomp item)
- (handle-stack-atom item))
- ((symbolp item)
- (handle-stack-symbol item)))))
+ ,@(filter #'identity (loop while code collect
+ (let ((item (car code)))
+ (setf code (cdr code))
+ (cond
+ ((eq item nil)
+ `(push nil *stack*))
+ ((stack-atomp item)
+ (handle-stack-atom item))
+ ((symbolp item)
+ (handle-stack-symbol item))))))
(car *stack*)))
(defmacro* ||| (&body body)
`(with-stack ,@body))
(defmacro* |||- (&body body)
`(with-stack- ,@body))
+(defmacro* |||p (&body body)
+ `(with-stack ,@body print-stack))
(defun stack-at-least (n)
(>= (length *stack*) n))
@@ -360,4 +378,26 @@
(||| word: foldl ;( list init qtn -- result )
swapd leach end:)
+(defstackword-immediate lisp-val:
+ (assert (stack-at-least 1) "stack: lisp-val: needs one word after it, at least.")
+ (assert-stack-predicates (symbolp) 'lisp-val:)
+ (let ((s (pop-stack)))
+ (push-stack (internf "{%s}" s))))
+
+(defstackword 2dip
+ (assert (stack-at-least 3) "stack: 2dip needs at least three arguments on the stack.")
+ (assert-stack-predicates (stack-quotationp) '2dip)
+ (let ((q (pop-stack))
+ (a (pop-stack))
+ (b (pop-stack)))
+ (push-stack b)
+ (push-stack a)
+ (push-stack q)
+ (|||- call)))
+
+;; (defstackword stack->list-until ;( symbol {items} symbol -- list )
+;; (|||- '(_ 2>eq) fry nil swap '( '(2>cons) dip
+
+
+
(provide 'with-stack)
View
26 with-stack.md
@@ -109,6 +109,28 @@ quotations (`curry`, `compose`), and some words for doing control
(`if`, and `loop`). Where possible, I am going to hew pretty close to
Factor's style, not Forth's.
+# Interpolation #
+
+You can use the stack to work with emacs values using stack
+interpolation. This can be accessed in two ways. In the first, you
+surround a variable name with `{}` to push that emacs variable value
+on the stack:
+
+ (let ((x 10))
+ (||| {x} 25 +)) ;-> 35
+
+In the second you use the immediate word `lisp-val:`, which does the
+same thing.
+
+ (let ((x 10))
+ (||| lisp-val: x 25 +)) ;-> 35
+
+Lisp val is an immediate word, so it is evaluated at compile time,
+with the future words and values making up the stack language source
+code on the stack. Immediate words transform the source code of the
+emacs stack language at run time. You can create them using
+`defstackword-immediate`.
+
# The Fry Word #
One of the things to wrap your head around when learning factor is
@@ -155,4 +177,6 @@ to emacs lisp functions which usually take two arguments
31 May 2010: added stack type checking macros for use in el, added
foldl and leach words. Added an "assert-stack-predicates" word which
-checks the types on the stack simply and easily.
+checks the types on the stack simply and easily.
+
+6 June 2010: added interpolation syntax and immediate word.

0 comments on commit ab9dc24

Please sign in to comment.