Add Lisp

2 files changed, 106 insertions, 2 deletions

diff --git a/Makefile b/Makefile
index 9a3f9cd..51fcc76 100644
--- a/Makefile
+++ b/Makefile
@@ -6,10 +6,17 @@ BINARIES := \
 	mendeleev-py \
 	mendeleev-tree-c \
 
-SCRIPTS := \
+LISP := \
+	clisp:mendeleev.lisp \
+	ecl:--shell:mendeleev.lisp \
+	sbcl:--script:mendeleev.lisp \
+
+PYTHON := \
+	pypy:mendeleev.py \
 	python2:mendeleev.py \
 	python3:mendeleev.py \
-	pypy:mendeleev.py
+
+SCRIPTS := $(LISP) $(PYTHON)
 
 .PHONY: build
 build: $(BINARIES)
@@ -116,3 +123,4 @@ prof-mendeleev-py.dat: mendeleev.py
 prof-mendeleev-py.txt: prof-mendeleev-py.dat
 	python3 -c 'import pstats; pstats.Stats("$<").sort_stats("tottime").print_stats()' > $@
 
+
diff --git a/mendeleev.lisp b/mendeleev.lisp
new file mode 100644
index 0000000..bdb35ab
--- /dev/null
+++ b/mendeleev.lisp
@@ -0,0 +1,96 @@
+(defconstant +elements+
+   #("?"
+     "Ac" "Ag" "Al" "Am" "Ar" "As" "At" "Au" "B"  "Ba" "Be" "Bh"
+     "Bi" "Bk" "Br" "C"  "Ca" "Cd" "Ce" "Cf" "Cl" "Cm" "Cn" "Co"
+     "Cr" "Cs" "Cu" "Db" "Ds" "Dy" "Er" "Es" "Eu" "F"  "Fe" "Fl"
+     "Fm" "Fr" "Ga" "Gd" "Ge" "H"  "He" "Hf" "Hg" "Ho" "Hs" "I"
+     "In" "Ir" "K"  "Kr" "La" "Li" "Lr" "Lu" "Lv" "Mc" "Md" "Mg"
+     "Mn" "Mo" "Mt" "N"  "Na" "Nb" "Nd" "Ne" "Nh" "Ni" "No" "Np"
+     "O"  "Og" "Os" "P"  "Pa" "Pb" "Pd" "Pm" "Po" "Pr" "Pt" "Pu"
+     "Ra" "Rb" "Re" "Rf" "Rg" "Rh" "Rn" "Ru" "S"  "Sb" "Sc" "Se"
+     "Sg" "Si" "Sm" "Sn" "Sr" "Ta" "Tb" "Tc" "Te" "Th" "Ti" "Tl"
+     "Tm" "Ts" "U"  "V"  "W"  "Xe" "Y"  "Yb" "Zn" "Zr"))
+
+(defconstant +nelems+
+  (1- (length +elements+)))
+
+(defconstant +elems+
+  (map 'vector #'string-downcase +elements+))
+
+(defun get-part (el sh)
+  (schar (elt +elems+ el) sh))
+
+(defun search-el (range sh ch)
+  (prog* ((top (+ (car range) (cdr range)))
+          (u top)
+          (l (car range))
+          m)
+        (loop while (< l u) do
+              (setf m (truncate (+ l u) 2))
+              (if (char< (get-part m sh) ch)
+                (setf l (1+ m))
+                (setf u m)))
+        (when (or (= l top) (char/= ch (get-part l sh)))
+          (setf (cdr range) 0) (return))
+        (setf u top
+              (car range) l)
+        (loop while (< l u) do
+              (setf m (truncate (+ l u) 2))
+              (if (char< ch (get-part m sh))
+                (setf u m)
+                (setf l (1+ m))))
+        (setf (cdr range) (- u (car range))) (return)))
+
+(defun divide (tail)
+  (prog ((range (cons 1 +nelems+))
+         (sh 0)
+         (r ()))
+        (loop
+          (search-el range sh (schar tail sh))
+          (when (= 0 (cdr range)) (return))
+          (incf sh)
+          (when (= sh (length (elt +elems+ (car range))))
+            (push (cons (car range) (subseq tail sh)) r)
+            (incf (car range)) (decf (cdr range)))
+          (when (= sh (length tail)) (return)))
+        (when (null r) (push (cons 0 (subseq tail 1)) r))
+        (return (reverse r))))
+
+(defun explode (tail)
+  (let ((sibs (divide tail))
+        (next (lambda (x)
+                (cons (car x)
+                      (when (string/= "" (cdr x))
+                        (explode (cdr x)))))))
+    (map-into sibs next sibs)))
+
+(defun print-plain (tree formula)
+  (loop for x in tree do
+        (vector-push (car x) formula)
+        (if (cdr x)
+          (print-plain (cdr x) formula)
+          (progn
+            (loop for i across formula do
+                  (format t " ~a" (elt +elements+ i)))
+            (fresh-line)))
+        (decf (fill-pointer formula))))
+
+
+(defun analyze (word)
+  (let ((formula (make-array (length word) :fill-pointer 0))
+        (tail (string-downcase word)))
+    (format t "~a:" word) (fresh-line)
+    (when (string/= "" tail)
+      (print-plain (explode tail) formula))))
+
+(defun program-args ()
+  (or
+   #+CLISP *args*
+   #+ECL   (cdr ext:*unprocessed-ecl-command-args*)
+   #+GCL   (cdr si::*command-args*)
+   #+SBCL  (cdr *posix-argv*)
+   nil))
+
+(loop for word in (program-args) do
+      (analyze word))
+