aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile12
-rw-r--r--mendeleev.lisp96
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))
+