fork download
copy 
  1. ;Syntax for (some) chemical formulae:
  2. ;  <formula> = "" | <element-with-multiplicity> <formula> | <group-with-multiplicity> <formula>
  3. ;  <element-with-multiplicity> = <element> <optional-number>
  4. ;  <group-with-multiplicity> = <group> <number>
  5. ;  <group> = "(" <formula> ")"
  6. ;  <element> = "C" | "H" | "O" | "Cl" | "F" | "Na" | "Pb" | "N"   
  7. ;  <optional-number> = <number> | ""
  8. ;  <number> = "2" | "3" | "4" | ...
  9.  
  10. (defun empty-clause (continuation input-string)
  11.   (funcall continuation input-string nil))
  12.  
  13. (defun match-and (clause1 clause2 &key (combinator #'list))
  14.   (lambda (continuation input-string)
  15.     (funcall clause1
  16.              (lambda (remainder1 value1)
  17.                (funcall clause2
  18.                         (lambda (remainder2 value2)
  19.                           (funcall continuation remainder2 (funcall combinator value1 value2)))
  20.                         remainder1))
  21.              input-string)))
  22.  
  23. (defun match-all (&rest clauses)
  24.   (if clauses
  25.     (match-and (car clauses)
  26.                (apply #'match-all (cdr clauses))
  27.                :combinator #'cons)
  28.     #'empty-clause))
  29.  
  30. (defun match-any (&rest clauses)
  31.   (lambda (continuation input-string)
  32.     (dolist (clause clauses)
  33.       (funcall clause continuation input-string))))
  34.  
  35. (defun make-literal-clause (string-to-match value)
  36.   (lambda (continuation input-string)
  37.     (unless (mismatch string-to-match input-string :end2 (min (length string-to-match)
  38.                                                               (length input-string)))
  39.       (funcall continuation (subseq input-string (length string-to-match)) value))))
  40.  
  41. (defclass chemical-element ()
  42.   ((name
  43.      :initarg :name
  44.      :reader name)
  45.    (chemical-symbol
  46.      :initarg :chemical-symbol
  47.      :reader chemical-symbol)
  48.    (atomic-weight
  49.      :initarg :atomic-weight
  50.      :reader atomic-weight)))
  51.  
  52. (defvar *elements*
  53.   (list (make-instance 'chemical-element
  54.                        :name "carbon"
  55.                        :chemical-symbol "C"
  56.                        :atomic-weight 12.011)
  57.         (make-instance 'chemical-element
  58.                        :name "hydrogen"
  59.                        :chemical-symbol "H"
  60.                        :atomic-weight 1.008)
  61.         (make-instance 'chemical-element
  62.                        :name "oxygen"
  63.                        :chemical-symbol "O"
  64.                        :atomic-weight 15.999)
  65.         (make-instance 'chemical-element
  66.                        :name "chlorine"
  67.                        :chemical-symbol "Cl"
  68.                        :atomic-weight 35.45)
  69.         (make-instance 'chemical-element
  70.                        :name "fluorine"
  71.                        :chemical-symbol "F"
  72.                        :atomic-weight 18.998403163)
  73.         (make-instance 'chemical-element
  74.                        :name "sodium"
  75.                        :chemical-symbol "Na"
  76.                        :atomic-weight 22.98976928)
  77.         (make-instance 'chemical-element
  78.                        :name "lead"
  79.                        :chemical-symbol "Pb"
  80.                        :atomic-weight 207.2)
  81.         (make-instance 'chemical-element
  82.                        :name "nitrogen"
  83.                        :chemical-symbol "N"
  84.                        :atomic-weight 14.007)))
  85.  
  86. (setf (symbol-function 'element-clause)
  87.       (apply #'match-any (mapcar
  88.                            (lambda (e)
  89.                              (make-literal-clause (chemical-symbol e) e))
  90.                            *elements*)))
  91.  
  92. (defun number-clause (continuation input-string)
  93.   (dotimes (i (length input-string))
  94.     (let ((code (char-code (char input-string i))))
  95.       (when (or (< code (char-code #\0))
  96.                 (> code (char-code #\9)))
  97.         (return))
  98.       (when (and (= i 0)
  99.                  (= code (char-code #\0)))
  100.         (return))
  101.       (unless (and (= i 0)
  102.                    (= code (char-code #\1)))
  103.         (funcall continuation
  104.                  (subseq input-string (1+ i))
  105.                  (read-from-string (subseq input-string 0 (1+ i))))))))
  106. (setf (symbol-function 'optional-number-clause)
  107.       (match-any #'empty-clause
  108.                  #'number-clause))
  109.  
  110. (defun element-with-multiplicity-clause (continuation input-string)
  111.   (funcall (match-all #'element-clause #'optional-number-clause)
  112.            (lambda (remainder value)
  113.              (if (cadr value)
  114.                (funcall continuation remainder (cons (car value) (cadr value)))
  115.                (funcall continuation remainder (car value))))
  116.            input-string))
  117.  
  118. (defun group-clause (continuation input-string)
  119.   (funcall (match-all (make-literal-clause "(" nil)
  120.                       'formula-clause
  121.                       (make-literal-clause ")" nil))
  122.            (lambda (remainder value)
  123.              (funcall continuation remainder (cadr value)))
  124.            input-string))
  125.  
  126. (defun group-with-multiplicity-clause (continuation input-string)
  127.   (funcall (match-all #'group-clause #'number-clause)
  128.            (lambda (remainder value)
  129.              (funcall continuation remainder (cons (car value) (cadr value))))
  130.            input-string))
  131.  
  132. (setf (symbol-function 'formula-clause)
  133.       (match-any
  134.         #'empty-clause
  135.         (match-and #'element-with-multiplicity-clause 'formula-clause :combinator #'cons)
  136.         (match-and #'group-with-multiplicity-clause 'formula-clause :combinator #'cons)))
  137.  
  138. (define-condition parsing-error (error) ())
  139.  
  140. (defun parse (clause input-string)
  141.   (block parse-block
  142.          (funcall clause
  143.                   (lambda (remainder value)
  144.                     (when (string= remainder "")
  145.                       (return-from parse-block value)))
  146.                   input-string)
  147.          (error 'parsing-error)))
  148.  
  149. (defun atom-counts-zero ()
  150.   (mapcar (lambda (e) (cons e 0)) *elements*))
  151.  
  152. (defun atom-counts-of-element (element)
  153.   (mapcar (lambda (e) (if (eq e element)
  154.                         (cons e 1)
  155.                         (cons e 0)))
  156.           *elements*))
  157.  
  158. (defun mult-atom-counts (n atom-counts)
  159.   (mapcar (lambda (p) (cons (car p) (* n (cdr p))))
  160.           atom-counts))
  161.  
  162. (defun add-atom-counts (&rest atom-counts)
  163.   (flet ((add (count1 count2)
  164.            (mapcar (lambda (p) (cons (car p)
  165.                                      (+ (cdr p)
  166.                                         (cdr (assoc (car p) count2)))))
  167.                    count1)))
  168.     (reduce #'add atom-counts :initial-value (atom-counts-zero))))
  169.  
  170. (defun atom-counts (parse-tree)
  171.   (if (consp parse-tree)
  172.     (if (numberp (cdr parse-tree))
  173.       (mult-atom-counts (cdr parse-tree) (atom-counts (car parse-tree)))
  174.       (apply #'add-atom-counts (mapcar #'atom-counts parse-tree)))
  175.     (if parse-tree
  176.       (atom-counts-of-element parse-tree)
  177.       (atom-counts-zero))))
  178.  
  179. (defun analyze-formula (formula-string)
  180.   (let* ((parse-tree (parse #'formula-clause formula-string))
  181.          (atom-counts (atom-counts parse-tree))
  182.          (atomic-weight (apply #'+ (mapcar (lambda (p)
  183.                                              (* (cdr p)
  184.                                                 (atomic-weight (car p))))
  185.                                            atom-counts))))
  186.     (format t "Chemical analysis for ~a: ~%" formula-string)
  187.     (format t "   contains~%")
  188.     (dolist (p atom-counts)
  189.       (when (> (cdr p) 0)
  190.         (format t "      ~a ~a atom~a~%" (cdr p) (name (car p)) (if (> (cdr p) 1) "s" ""))))
  191.     (format t "   has atomic weight ~a~%" atomic-weight)
  192.     (finish-output nil)))
  193.  
  194. ; (analyze-formula "C6H2(NO2)3CH3") ; TNT
  195. (analyze-formula "CCl2F2") ; dichlorodifluoromethane
  196. (analyze-formula "NaHCO3") ; sodium bicarbonate
  197. (analyze-formula "C4H8(OH)2") ; trimethylene glycol monomethyl ether
  198. (analyze-formula "PbCl(NH3)2(COOH)2") ; ?!?
Success #stdin #stdout 0s 203840KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Chemical analysis for CCl2F2: 
   contains
      1 carbon atom
      2 chlorine atoms
      2 fluorine atoms
   has atomic weight 120.90781
Chemical analysis for NaHCO3: 
   contains
      1 carbon atom
      1 hydrogen atom
      3 oxygen atoms
      1 sodium atom
   has atomic weight 84.00577
Chemical analysis for C4H8(OH)2: 
   contains
      4 carbon atoms
      10 hydrogen atoms
      2 oxygen atoms
   has atomic weight 90.122
Chemical analysis for PbCl(NH3)2(COOH)2: 
   contains
      2 carbon atoms
      8 hydrogen atoms
      4 oxygen atoms
      1 chlorine atom
      1 lead atom
      2 nitrogen atoms
   has atomic weight 366.746
https://ideone.com/nCN8z3
language:
Common Lisp (sbcl 1.4.16)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!