001  (ns ^{:doc "Simplify a parse tree."
002        :author "Simon Brooke"}
003   mw-parser.simplify)
004  
005  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
006  ;;;;
007  ;;;; mw-parser: a rule parser for MicroWorld.
008  ;;;;
009  ;;;; This program is free software; you can redistribute it and/or
010  ;;;; modify it under the terms of the GNU General Public License
011  ;;;; as published by the Free Software Foundation; either version 2
012  ;;;; of the License, or (at your option) any later version.
013  ;;;;
014  ;;;; This program is distributed in the hope that it will be useful,
015  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
016  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
017  ;;;; GNU General Public License for more details.
018  ;;;;
019  ;;;; You should have received a copy of the GNU General Public License
020  ;;;; along with this program; if not, write to the Free Software
021  ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
022  ;;;; USA.
023  ;;;;
024  ;;;; Copyright (C) 2014 Simon Brooke
025  ;;;;
026  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
027  
028  (declare simplify)
029  
030  (defn simplify-second-of-two
031    "There are a number of possible simplifications such that if the `tree` has
032    only two elements, the second is semantically sufficient."
033    [tree]
034    (if (= (count tree) 2) (simplify (nth tree 1)) tree))
035  
036  (defn simplify-chained-list
037    "Some parse trees take the form 
038     `[:X [:Y 1] :NOISE :NOISE [:X [:Y 2] :NOISE :NOISE [:X [:Y 3]]]]`
039     where what's wanted is `[:X [:Y 1] [:Y 2] [:Y 2]]` -- :DISJUNCT-VALUE is a case
040     in point. This takes such a parse `tree`, where `branch-tag` is the tag of
041     the enclosing form and `leaf-tag` is the tag of the form to be collected, and 
042     returns the desired form."
043    [tree branch-tag leaf-tag]
044    (cons
045     (first tree)
046     (reverse
047      (loop [chain (rest tree) v '()]
048        (let [car (first chain)]
049          (cond (empty? chain) v
050                (coll? car) (let [caar (first car)]
051                              (cond
052                                (= branch-tag caar) (recur car v)
053                                (= leaf-tag caar) (recur
054                                                   (rest chain)
055                                                   (cons (simplify car) v))
056                                :else (recur (rest chain) v)))
057                :else (recur (rest chain) v)))))))
058  
059  (defn simplify
060    "Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with
061    semantically identical simpler fragments"
062    [tree]
063    (if
064     (coll? tree)
065      (case (first tree)
066        :ACTION (simplify-second-of-two tree)
067        :ACTIONS (cons (first tree) (simplify (rest tree)))
068        :AND nil
069        :CHANCE-IN nil
070        :COMPARATIVE (simplify-second-of-two tree)
071        :CONDITION (simplify-second-of-two tree)
072        :CONDITIONS (simplify-second-of-two tree)
073        :DISJUNCT-EXPRESSION (simplify-chained-list tree :DISJUNCT-VALUE :VALUE)
074        :EXPRESSION (simplify-second-of-two tree)
075        :IN nil
076        :PROPERTY (simplify-second-of-two tree)
077        :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree)
078        :OR nil
079        :SPACE nil
080        :THEN nil
081        :VALUE (simplify-second-of-two tree)
082        (remove nil? (map simplify tree)))
083      tree))
084  
085  (defn simplify-determiner-condition
086    [tree]
087    (apply vector
088           (cons :DETERMINER-CONDITION
089                 (cons
090                  (simplify-second-of-two (second tree))
091                  (rest (rest tree))))))