[-*- emacs-lisp -*-]
[
 Copyright 2012 Ken Takusagawa
           
           This program is free software: you can redistribute it and/or modify
           it under the terms of the GNU General Public License as published by
           the Free Software Foundation, either version 3 of the License, or
           (at your option) any later version.
           
           This program is distributed in the hope that it will be useful,
           but WITHOUT ANY WARRANTY; without even the implied warranty of
           MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
           GNU General Public License for more details.
           
           You should have received a copy of the GNU General Public License
           along with this program.  If not, see <http://www.gnu.org/licenses/>.
]
[-----grammar
 (gz start (prog))
 (gz prog (module))
 (gz module (id language-pragma-opt exports imports topdecl-star
                ::pr("[[language-pragma-opt]]module [[id]] [[exports]] where {\n[[imports]]\n"
                     "[[topdecl-star('',';\n\n','\n')]]}\n")))
 (gz language-pragma ( :language-pragma f id-non-star j
                                        ::pr
                                        ("{-# LANGUAGE [[id-non-star('',',','')]] #-}\n")))
 (gz exports
     (f export-star j
                ::pr("[[export-star('\n  ( ','\n  , ','\n  )')]]"))
     (:export-everything ::pr("")))
 (gz export
     (id)
     (f :module-export id j ::pr("module [[id]]"))
     (f :type-export id constructors-export j ::pr("[[id]][[constructors-export]]"))
     )
 (gz constructors-export
     (:all-constructors ::pr("(..)"))
     (id-non-star ::pr("[[id-non-star('(',',',')')]]"))
     )
 (gz imports (f import-star j
                ::pr("[[import-star('',';\n',';\n')]]")))
 (gz import(id ::pr( "import [[id]]"))
     (f :qualified (original-name ::is id) (new-name ::is id) j
        ::pr ( "import qualified [[original-name]] as [[new-name]]"))
     (f :specific id id-non-star j
        ::pr ("import [[id]][[id-non-star('(',',',')')]]"))
     (f :hiding import id-non-star j
        ::pr("[[import]] hiding[[id-non-star('(',',',')')]]")
        [dunno if this will work for complicated cases]
        ))
 (gz type-class (f decl-mark (class-name ::is id) :type-class context-opt f id-non-plus j type-class-decl-star j
                   ::pr("class [[context-opt]][[class-name]] [[id-non-plus('',' ','')]] where{\n"
                        "[[type-class-decl-star('',';\n','\n')]]}")))
 (gz topdecl (decl) (data)(type-synonym)(newtype)(instance)(type-class))
 (gz type-class-decl (type-signature)(decl))
 (gz type-signature (f decl-mark name :tysig ret-type-and-params j
                       ::pr("[[name]] :: [[ret-type-and-params]]")))
 (gz instance (f :instance (type ::is id) (name ::is simpletype)  context-opt decls j
                 ::pr ("instance [[context-opt]] [[type]] ([[name]]) where [[decls]]")))
 [(gz instance (f :instance context-opt (type ::is id) simpletype-plus :x decls j
                  ::pr ("instance [[context-opt]][[type]] [[simpletype-plus('(',')(',')')]] where [[decls]]")))]
 (gz newtype (f decl-mark (name ::is id) :newtype type-vars-opt  constr-or-wrap deriving-opt j
                ::pr("newtype [[name]] [[type-vars-opt]] = [[constr-or-wrap{my_name}]][[deriving-opt]]")))
 (gz constr-or-wrap ::gets "tr-id*{name}" (outer-constr)(wrap-constr ::pr("[[wrap-constr{name}]]")))
 (gz wrap-constr ::gets "tr-id*{name}"
     ( :wrap id
             ::pr(
                  (::c "name->print();")
                  " {un"
                  (::c "name->print();")
                  " :: [[id]]}")))

 (gz deriving (:deriving f id-non-plus j
                         ::pr("\n  deriving [[id-non-plus('(',', ',')')]]")))
 (gz id-non (id))
 (gz type-synonym (f decl-mark id :type-synonym type-vars-opt type j
                     ::pr("type [[id]] [[type-vars-opt]] = [[type]]")))
 (gz data (f decl-mark id :data type-vars-opt constrs deriving-opt j ::pr("data [[id]] [[type-vars-opt]] = [[constrs]][[deriving-opt]]")))
 (gz simpletype (f id-non-plus j ::pr ("[[id-non-plus('',' ','')]]")))
 (gz type-vars (:args f id-non-star j ::pr ("[[id-non-star('',' ','')]]")))
 (gz constrs(outer-constr-star ::pr("[[outer-constr-star('','\n  | ','')]]")))
 (gz field-type-and-param (f param type j
                             ::pr("[[param]] :: [[type]]")))
 (gz type-and-param ( f param type j ::pr("[[type]]")))
 (gz outer-constr(outer-positional-constructor) (field-label-constructor) )
 (gz field-label-constructor(f type-ctor :field field-type-and-param-star j
                               ::pr("[[type-ctor]][[field-type-and-param-star('{',', ','}')]]")))
 (gz decls (  decl-star  ::pr("{[[decl-star('\n',';\n','\n')]]}")))
 (gz context (:context f a-context-plus j ::pr
                       ("[[a-context-plus('(',', ',')')]] => ")))
 (gz a-context [(f (type ::is id) id-non-plus j
                   ::pr("[[type]] [[id-non-plus('',' ','')]]"))]
     (f (class ::is id) type-plus j
        ::pr("[[class]] [[type-plus('',' ','')]]"))
     )
 (gz forall (:forall f id-non-plus j
                     ::pr("forall [[id-non-plus('',' ','')]] . ")))
 (gz ret-type-and-params
     (type f type-and-param-star j forall-opt context-opt
           ::pr("[[forall-opt]][[context-opt]][[type-and-param-star('',' \x2d> ','')]]"
                (::c "if(my_type_and_param_star->v.size()>0)out(' \x2d> ');")
                "[[type]]")))

 (gz decl (f decl-mark name :fun haddock-opt ret-type-and-params  expr j
             ::pr("[[haddock-opt]]"
                  "[[name]] :: [[ret-type-and-params]];\n"
                  "[[name]]"
                  (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                       "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                       "assert(t);"
                       "out(' ');"
                       "t->my_param->print();" "}")
                  " = [[expr]]"))
     (f decl-mark name :fun :no-sig ret-type-and-params  expr j
        ::pr("[[name]]"
             (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                  "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                  "assert(t);"
                  "out(' ');"
                  "t->my_param->print();" "}")
             " = [[expr]]"))
     (f decl-mark name :simple  expr j
        ::pr("[[name]] = [[expr]]"))
     )
 (gz name (id))
 (gz outer-positional-constructor ["this one is sketchy"]
     (type-ctor ::pr("[[type-ctor]]"))
     (f type-ctor type-star j
        ::pr("[[type-ctor]][[type-star(' ',' ','')]]"))
     (f :tuple type-plus j
        ::pr("[[type-plus('(',', ',')')]]"))
     )

 (gz positional-constructor ["this one is sketchy"]
     (type-ctor ::pr("[[type-ctor]]"))
     (f type-ctor type-star j
        ::pr("([[type-ctor]][[type-star(' ',' ','')]])"))
     (f :tuple type-plus j
        ::pr("[[type-plus('(',', ',')')]]"))
     )

 (gz pattern
     (id)
     ["avoid pattern-star because it causes weird spacing"]
     (f  pattern-ctor j
         ::pr ("[[pattern-ctor]]"))
     (f  pattern-ctor pattern-plus j
         ::pr ("([[pattern-ctor]] [[pattern-plus('',' ','')]])"))
     
     (f pattern-ctor :fpat f fpat-star j j
        ::pr ("([[pattern-ctor]][[fpat-star('{',', ','}')]])"))

     (f :ptuple pattern-plus j [pattern-plus cuz :nil exists for empty lists]
        ::pr("[[pattern-plus('(',', ',')')]]"))

     (f :plist pattern-plus j [pattern-plus cuz :nil exists for empty lists]
        ::pr("[[pattern-plus('\x5b',', ','\x5d')]]"))

     (f :pchar astring j ::pr("\x27[[astring]]\x27"))

     (f :pstring astring j ::pr("\x22[[astring]]\x22"))

     (f :as id pattern j ::pr("([[id]]@[[pattern]])"))

     )
 (gz pattern-ctor (id) (:cons ::pr ("(:)")) (:nil ::pr ("[]"))
     (:paren id  ::pr("([[id]])")) ["workaround for Qualified parenthesized constructors"]
     ( :v id type ::pr("([[id]] :: [[type]])"))
     )

 (gz fpat (f (variable ::is id) pattern j
             ::pr("[[variable]] = [[pattern]]")))

 (gz type (f :fn ret-type-and-params j ::pr ("([[ret-type-and-params]])"))
     (:inforall f id-non-plus j type  ::pr("(forall [[id-non-plus('',' ','')]] . [[type]])"))
     (:unit ::pr("()"))
     (positional-constructor)
     (f :strict type j  ::pr ("![[type]]"))
     )
 [(gz typepls (paren-type-plus))]
 [(gz strict-type (type ::pr( "[[type]]"))
     (f :strict type j ::pr("![[type]]"))
     [(f :generic id j ::pr (" [[id]] "))])]
 (gz type-ctor(id)(:list ::pr ("[]")) [(:nondet ::pr ("[]"))])
 (gz param (pattern))
 (gz qastring  (astring ::pr("\x22[[astring]]\x22")))

 (gz expr (id) (:mcons ::pr ("(:)"))
     (f :chain astring expr-plus j ::pr
        ([("[[expr-plus('(',' op ',')')]]")]
         "("
         (::c "for(many_trees::const_iterator pos=my_expr_plus->v.begin();pos!=my_expr_plus->v.end();++pos){")
         (::c "if(pos!=my_expr_plus->v.begin()){")
         "[[astring]]"
         (::c "}(*pos)->print();}")
         ")"
         ))
     (f :join expr-plus j ::pr("[[expr-plus('(',' >>= ',')')]]"))
     (f :cc expr-star j ::pr ("[[expr-star('(',' ++ ',')')]]"))
     (f :msum expr-star j ::pr ("[[expr-star('(',' \x60mplus\x60 ',')')]]"))
     (f :rpipe expr-plus j ::pr[("[[expr-star('(',' $ ',')')]]")]
        (["http;//gcc.gnu.org/bugzilla/show_bug.cgi?id=11729"]
         (::c "for(many_trees::reverse_iterator pos = my_expr_plus->v.rbegin();"
              "pos!=my_expr_plus->v.rend();++pos){")
         "("
         (::c "(*pos)->print();" "}")
         (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();"
              "pos!=my_expr_plus->v.end();++pos){")
         ")"
         (::c  "}")
         ))
     (f :rcompose expr-plus j ::pr
        ("("
         (::c "for(many_trees::reverse_iterator pos = my_expr_plus->v.rbegin();"
              "pos!=my_expr_plus->v.rend();++pos){")
         (::c "if(pos!=my_expr_plus->v.rbegin())")
         " . "
         (::c "(*pos)->print();" "}")
         ")"
         ))
     (qastring)
     (f :lit astring j ::pr("[[astring]]"))
     (f :ty type expr j ::pr("([[expr]] :: [[type]])"))
     (f (fun-name ::is expr) expr-star j
        ::pr ("([[fun-name]][[expr-star(' ',' ','')]])"))
     (f :do  stmt-star  j ::pr("(do {\n[[stmt-star('  ','\n  ','\n')]]})"))
     (f :case expr  alt-star  j
        ::pr("(case [[expr]] of {\n[[alt-star('  ',';\n  ','\n')]]})"))
     (f :mzerocase expr  alt-star  j
        ::pr("(case [[expr]] of {\n[[alt-star('  ',';\n  ',';\n')]]"
             "  _ -> mzero\n"
             "})"))
     (f :case expr alt-plus :else (underbar ::is expr) j
        ["the else is there so the grammar does not have a reduce/reduce conflict"]
        ::pr("(case [[expr]] of {\n[[alt-plus('  ',';\n  ',';\n')]]"
             "  _ -> [[underbar]]\n"
             "})"))
     (f :case expr :else (underbar ::is expr) alt-star  j
        ::pr("(case [[expr]] of {\n[[alt-star('  ',';\n  ',';\n')]]"
             "  _ -> [[underbar]]\n"
             "})"))
     (f :lcase alt-star j
        ::pr("(\x5clambda_case_var ->"
             "case lambda_case_var of {\n"
             "[[alt-star('  ',';\n  ','\n')]]})"))
     (f :lcase alt-plus :else (underbar ::is expr) j
        ::pr("(\x5clambda_case_var ->"
             "case lambda_case_var of {\n"
             "[[alt-plus('  ',';\n  ',';\n')]]"
             "  _ -> [[underbar]]\n"
             "})"))
     (f :lcase :else (underbar ::is expr) alt-star j
        ::pr("(\x5clambda_case_var ->"
             "case lambda_case_var of {\n"
             "[[alt-star('  ',';\n  ',';\n')]]"
             "  _ -> [[underbar]]\n"
             "})"))
     (f :let decl-star expr j
        ::pr("(let {[[decl-star('\n',';\n','\n')]]} in [[expr]])"))
     (f :rlet expr decl-star j
        ::pr("(let {[[decl-star('\n',';\n','\n')]]} in [[expr]])"))
     (f :cfd expr assignments-star j
        ::pr("([[expr]][[assignments-star('{',', ','}')]])"))
     (f :mlist expr-star j ::pr("[[expr-star('\x5b',', ','\x5d')]]"))
     (f :cons-list expr-plus j ::pr("[[expr-plus('(',':',')')]]"))
     (f :mtuple expr-star j ::pr("[[expr-star('(',', ',')')]]"))
     (:nothing  ::pr ("()"))
     (f :lambda name ret-type-and-params expr j
        ::pr("(let {[[name]] :: [[ret-type-and-params]];\n"
             "[[name]]"
             (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                  "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                  "assert(t);"
                  "out(' ');"
                  "t->my_param->print();" "}")
             " = [[expr]]} in [[name]])"))
     (f :lambda-simple id-non expr j
        [recommended only for reordering arguments to functions
                     and other simple expressions]
        [only one variable to keep it simple]
        ::pr ("(\x5c[[id-non]] -> [[expr]])"))
     (f :field-edit expr field-edit-plus j
        [plus is required by Haskell]
        ::pr("([[expr]][[field-edit-plus('{',',','}')]])"))
     )
 (gz field-edit (f id expr j ::pr ("[[id]] = [[expr]]")))

 (gz assignments (f id expr j ::pr("[[id]] = [[expr]]")))
 (gz stmt (expr ::pr("[[expr]];"))
     (f ":=" pattern expr j ::pr("[[pattern]] <- [[expr]];"))
     (f :dlet decl-star j ::pr ("let {[[decl-star('\n',';\n','\n')]]};"))
     )
 (gz alt (f  pattern expr-or-gpat j
             ::pr("[[pattern]][[expr-or-gpat]]")))
 (gz expr-or-gpat
     (expr ::pr (" -> [[expr]]"))
     (where-opt :gpats pred-expr-star [silly lookahead limitation]
                ::pr ("[[pred-expr-star('\n    ','\n    ','')]][[where-opt]]\n    "
                      )))
 (gz pred-expr ( f (pred ::is expr) (do ::is expr) j
                   ::pr ("| [[pred]] -> [[do]]")))
 (gz where (:where decls ::pr ("\n    where [[decls]]")))
 (gz decl-mark (":"))
 (gz haddock ( :doc f docline-star j
                    ::pr ("[[docline-star('\x7b\x2d |','\n',' \x2d\x7d\n')]]")))
 (gz docline (astring))
 ]

Main :language-pragma
(
 ScopedTypeVariables
 )
:export-everything

(
 
 (:specific System.Environment getArgs)
 (:specific Control.Monad guard)
 Text.Printf
 )

(: main :fun (IO :unit) ()
   (:join
    getArgs
    (:lcase
     ((:plist(:pstring "nothing"))(return :nothing))
     ((:plist n)(:rpipe n 
                        read 
                        Complexity 
                        list-expr-of-complexity [listn] 
                        (filter ok-commutative) 
                        (filter (:rcompose bad-expr not)) 
                        (mapM- ans)))
     :else
     (putStrLn "need max complexity")
     )))
(: euler-constant :fun Double () (exp 1))
(: phi :fun Double () (/ (+ 1 (sqrt 5))2))
(: Expr :data
   E
   Pi
   Phi
   TwoPi
   InvPhi
   Zero
   Unity
   Two
   (Add Expr Expr)
   (Sub Expr Expr)
   (Mul Expr Expr)
   (Div Expr Expr)
   (Pow Expr Expr)
   (Root Expr Expr)
   (Log Expr Expr)
   :deriving (Show Ord Eq)
   )

(: evalop :fun (Maybe Double) ((op(:fn Double ((x Double)(y Double))))
			       (x Expr)
			       (y Expr))
   (:do
    (:= (:v jx Double) (eval x))
    (:= (:v jy Double) (eval y))
    (return (op jx jy))
    ))
(: loglimit :fun Double ()
   (* 1023 (log 2)))
(: eval :fun (Maybe Double) ((e Expr))
   (:case 
    e
    (E (return euler-constant))
    (Pi (return pi))
    (Phi (return phi))
    (TwoPi (return (* 2 pi)))
    (InvPhi (return (/ 1 phi)))
    (Zero (return 0))
    (Unity (return 1))
    (Two (return 2))
    ((Add x y)(evalop + x y))
    ((Sub x y)(evalop - x y))
    ((Mul x y)(evalop * x y))
    ((Div x y)(:do
	       (:= (:v jy Double) (eval y))
	       (guard (/= 0 jy))
	       (:= (:v jx Double) (eval x))
	       (return (/ jx jy))))
    ((Pow mx my)(:do
		 (:= (:v x Double) (eval mx))
		 (:= (:v y Double) (eval my))
		 (guard (<= 0 x))
		 (guard (< (* y (log x)) loglimit))
		 (return (** x y))))
    ((Root base expo)(eval (Pow base (eReciprocal expo))))
    ((Log mbase mx)(:do
		    (:= (:v x Double) (eval mx))
		    (:= (:v base Double) (eval mbase))
		    (guard (< 0 x))
		    (guard (< 0 base))
		    (guard (/= 1 base))
		    (return (/ (log x)(log base)))))
    ))

(: leaf :fun (:list Expr) ()
   (:mlist E Pi Phi TwoPi InvPhi Zero Unity Two [(eSqrt Two)]))

(: Complexity :newtype (Complexity Integer) :deriving(Show))

(: list-expr-of-complexity :fun (:list Expr) ((n Complexity))
   (:case n
	  ((Complexity 0) (:mlist))
	  ((Complexity 1) leaf)
	  :else
	  (:do
	   (:join (:mlist False True)
		  (:lcase
		   (False
		    (:do
		     (:= f one-arg)
		     (:= x (list-expr-of-complexity (pred-complexity n)))
		     (return (f x))))
		   (True
		    (:do
		     (:= f two-arg)
		     (:= first (enum-complexity (pred-complexity n)))
		     (:= x (list-expr-of-complexity first))
		     (:= y (list-expr-of-complexity (subtract-complexity (pred-complexity n) first)))
		     (return (f x y))))
		   )))))

(: enum-complexity :fun (:list Complexity) (((Complexity cmax) Complexity))
   (:rpipe cmax (enumFromTo 0) (map Complexity)))
(: subtract-complexity :fun Complexity (((Complexity x)Complexity)
                                        ((Complexity y)Complexity))
   (Complexity (- x y)))
(: pred-complexity :fun Complexity (((Complexity x)Complexity))
   (Complexity (pred x)))

(: listn :fun (:list Expr)((n Complexity))
   (concatMap list-expr-of-complexity (enum-complexity n)))

(: one-arg :fun (:list (:fn Expr ((x Expr))))()
   (:mlist eSqrt eSqr eNegate eReciprocal eDouble))
(: eSqrt :fun Expr ((x Expr))
   (Root x Two))
(: eSqr :fun Expr ((x Expr))
   (Pow x Two))
(: eNegate :fun Expr ((x Expr))
   (Sub Zero x))
(: eReciprocal :fun Expr ((x Expr))
   (Div Unity x))
(: eDouble :fun Expr ((x Expr))
   (Mul Two x))

(: two-arg :fun (:list (:fn Expr ((x Expr)(y Expr))))()
   (:mlist Add Sub Mul Div Pow Root Log))

(: ans :fun (IO :unit) ((e Expr))
   (:case (eval e)
	  (Nothing (return :nothing))
	  ((Just x)
	   (:case True [(clock x)]
		  (True (putStrLn(:cc (printf "%.6f" x)" "(show e))))
		  :else (return :nothing)))
	  ))
(: clock :fun Bool ((x Double))
   (&& (< 1 x) (< x 13)))

(: ok-commutative :fun Bool ((e Expr))
   (:let
    (: twook :fun (:fn Bool ((x Expr)(y Expr))) ()
       (two-boilerplate ok-commutative &&))
    (:case e
	   (E True)(Pi True)(Phi True)(TwoPi True)(InvPhi True)(Zero True)(Unity True)(Two True)
	   ((Add x y)(&& (<= x y) (twook x y)))
	   ((Mul x y)(&& (<= x y) (twook x y)))
	   ((Sub x y)(twook x y))
	   ((Div x y)(twook x y))
	   ((Root x y)(twook x y))
	   ((Log x y)(twook x y))
	   ((Pow x y)(twook x y))
	   )))

(: bad-denominator :fun Bool ((e Expr))
   (:case e
	  (Phi True)(InvPhi True)
	  (Unity True)(Zero True)
	  ((Div _ _)True)
	  :else
	  False
	  ))

(: bad-expr-inner :fun Bool ((e1 Expr))
   (:let
    (: two-bad :fun Bool ((x Expr)(y Expr))
       (two-boilerplate bad-expr-inner || x y))
    (: bad-log :fun Bool ((base Expr)(e Expr))
       (:case e
	      ((Mul x y)(two-bad (Log base x)(Log base y)))
	      ((Div x y)(two-bad (Log base x)(Log base y)))
	      ((Pow x _)(bad-expr-inner (Log base x)))
	      :else
	      False))
    (:case e1
	   (E False)(Pi False)(Phi False)(TwoPi False)(InvPhi False)(Zero False)(Unity False)(Two False)
	   ((Add (Sub x y) (Sub fy fx)):gpats((&&(== x fx)(== y fy))True))
	   ((Add _ (Log InvPhi _))True) [Sub _ (Log Phi _)]
	   ((Add (Log x Phi)(Log y InvPhi)):gpats((== x y)True))
	   ((Add Pi Pi)True)
	   ((Add Unity Unity)True)
	   ((Add _ Zero)True)
	   ((Add Zero _)True)
	   ((Add x y)(||(two-bad x y)(== x y))) [equals should by Mul Two x]
	   ((Sub _ (Sub _ _))True)
	   ((Sub InvPhi Phi)True)
	   ((Sub Phi InvPhi) True)
	   ((Sub Pi TwoPi)True)
	   ((Sub _ Zero)True)
           ((Sub Two Unity)True)
	   ((Sub x y)(|| (two-bad x y) (== x y)))
	   ((Mul Zero _)True)
	   ((Mul _ Zero)True)
	   ((Mul Unity _)True)
	   ((Mul _ Unity)True)
	   ((Mul Phi InvPhi)True)
	   ((Mul x y)(or(:mlist(two-bad x y)
			       (== x y)
			       )))
	   ((Div _ Zero)True)
           ((Div Zero _)True)
	   ((Div _ Unity)True)
	   ((Div _ Phi)True)
	   ((Div TwoPi Pi)True)
	   ((Div Pi TwoPi)True)
	   ((Div _ InvPhi)True) [sqr phi]
	   ((Div x y)(or(:mlist(two-bad x y)
			       (== x y)
			       (bad-denominator y)
			       )))
	   ((Pow Zero _)True)
	   ((Pow Unity _)True)
	   ((Pow _ Zero)True)
	   ((Pow _ Unity)True)
	   ((Pow (Root _ x) y):gpats((== x y)True))
	   ((Pow (Pow _ _) _)True)
	   ((Pow x y)(or(:mlist(two-bad x y))))
	   ((Root Zero _)True)
	   ((Root Unity _)True) [assuming 1 is the "only" root of unity]
	   ((Root _ Unity)True)
	   ((Root _ Phi)True)
	   ((Root _ InvPhi)True)
	   ((Root _ (Div _ _))True)
	   ((Root x y)(or(:mlist(two-bad x y))))
           ((Log _ Unity)True)
	   ((Log Phi InvPhi)True) [negate 1]
	   ((Log InvPhi Phi)True) [negate 1]
	   ((Log x y)(or(:mlist(two-bad x y)
			       (== x y)
			       (bad-log y x)
			       (bad-log x y)
			       )))
	   ))
   )


(: bad-expr :fun Bool ((e Expr))
   (:rpipe e [non-special-terms] bad-expr-inner))
(: two-boilerplate :fun b ((process(:fn b((x a))))
			   (join (:fn b ((x b)(y b))))
			   (x a)(y a))
   (join (process x)(process y)))