aboutsummaryrefslogtreecommitdiff
path: root/mendeleev.lisp
blob: a7e794506266605bf36c32c3b9e7dcf376dd956c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
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 split (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 (split 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))