[-*- Mode: emacs-lisp -*-]
[Copyright 2011 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('(',', ',')')]]")) (:export-everything ::pr("")))
 (gz export (id)
     (f :module-export id j ::pr("module [[id]]"))
     )
 (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('(',',',')')]]"))
     )

 (gz type-class (f decl-mark (class-name ::is id) :type-class context-opt  id-non-plus f type-class-decl-star j 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 :tysig name ret-type-and-params j
                       ::pr("[[name]] :: [[ret-type-and-params]]")))
 (gz instance (f :instance (type ::is id) (name ::is simpletype)  decls j
                 ::pr ("instance [[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}" (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(" 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(constr-star ::pr("[[constr-star('',' | ','')]]"))

     )
 (gz field-type-and-param (f param type j
                             ::pr("[[param]] :: [[type]]")))
 (gz type-and-param ( f param type j ::pr("[[type]]")))
 (gz constr(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')]]}\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 ret-type-and-params  expr j
             ::pr("[[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 positional-constructor ["this one is sketchy"]
     (type-ctor ::pr("[[type-ctor]]"))
     (f   type-ctor typepls-opt j
          ::pr("[[type-ctor]][[typepls-opt]]"))
     (f :tuple type-plus j
        ::pr("[[type-plus('(',', ',')')]]"))
     )
 (gz pattern
     (id)
     (f  pattern-ctor pattern-star j
         ::pr ("([[pattern-ctor]] [[pattern-star('',' ','')]])"))

     (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 ("[]")))

 (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]])")) (:unit ::pr("()"))
     (positional-constructor))
 (gz typepls (paren-type-plus))
 (gz paren-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 ("(:)")) [(:nil ::pr ("[]"))]
     [(f :pipe expr-plus j ::pr[("[[expr-star('(',' $ ',')')]]")]
         (
          (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();"
               "pos!=my_expr_plus->v.end();++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 :join expr-plus j ::pr("[[expr-plus('(',' >>= ',')')]]"))

     (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
        [("[[expr-plus('(',' . ',')')]]")]
        ("("
         (::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();" "}")
         ")"
         )
        )

     (f :cc expr-star j ::pr ("[[expr-star('(',' ++ ',')')]]"))
     (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 :construct ctor expr-star j
         ::pr ("([[ctor]] [[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 :case expr alt-star :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-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-star :else (underbar ::is expr) 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')]]}\n in [[expr]])"))
     (f :rlet expr decl-star j
        ::pr("(let {[[decl-star('\n',';\n','\n')]]}\n in [[expr]])"))
     (f :cfd expr assignments-star j
        ::pr("([[expr]][[assignments-star('{',', ','}')]])"))
     [(f :compose (a ::is expr) (b ::is expr) j ::pr("((.)[[a]] [[b]])"))]
     [(:compose ::pr ("(.)"))]
     [(f :compose expr-plus j ::pr ("[[expr-plus('(',' . ',')')]]"))]
     (f :mlist expr-star j ::pr("[[expr-star('\x5b',', ','\x5d')]]"))
     (f :cons-list expr-star j ::pr("[[expr-star('(',':',')')]]"))
     (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]])"))

     )


 (gz assignments (f id expr j ::pr("[[id]] = [[expr]]")))
 (gz stmt (expr ::pr("[[expr]];"))
     (f ":=" pattern type expr j ::pr("[[pattern]] :: [[type]] <- [[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 ("\n[[pred-expr-star('','','')]] [[where-opt]]"
              )))
 (gz pred-expr ( f (pred ::is expr) (do ::is expr) j
                   ::pr ("| [[pred]]\n -> [[do]]\n")))
 (gz where (:where decls ::pr ("where [[decls]]")))

 (gz decl-mark (":"))
 ]



Main :language-pragma
(
 ScopedTypeVariables
 [PatternSignatures]
 GeneralizedNewtypeDeriving
 )
(main)
(
 Data.Maybe
 Data.List
 [Array]
 Data.Char
 )

(: main :fun (IO :unit) ()
   [(:join
    getContents
    (:rcompose
     id
     putStrLn
     ))]
   example
)
(: Permutation :type-synonym :args (a b) (:list (:tuple a b)))
(: enum-zero-size :fun (:list Int) ((length Int))
   (take length (enumFrom 0)))
(: do-substitution :fun b ((p (Permutation a b))(x a)):context ((Eq a))
   (:rpipe (lookup x p) fromJust))

(: do-permutation :fun (:list a) ((template(:list Int))(l(:list a)))
(:do
  (:= i Int (enum-zero-size (length l)))
  (return (!! l (!! template i)))
))

(: bacon-list :fun (:list String) ()
   (:rpipe "ab" (replicate 5) sequence))

(: a32lphabet :fun String () latin-alphabet-32)
(: punctuation-alphabet :fun String ()
   (++ alphabet26
       ".,'-_\\"))
(: latin-alphabet-32 :fun String ()
   (++ alphabet26
       (map toEnum (:mlist 229 233 234 243 248 252
                           ))))

(: alphabet26 :fun String ()
   (enumFromTo (head "a") (head "z")))
[concatMap {do_substitution {zip a32lphabet bacon_list}} "hello"]
(: bacon-sep :fun (:fn(:list String) ((s String)))()
   (substitution a32lphabet bacon-list))
(: bacon :fun (:fn String ((s String)))()
   (:rcompose bacon-sep concat))
(: un-bacon :fun String ((s String))
   (:rpipe s (n-chunk 5) (map (do-substitution (zip bacon-list a32lphabet)))))
(: arrange-into-columns :fun (:list(:list a))((num-columns Int)(l (:list a)))
   (:rpipe l (n-chunk num-columns) transpose))

(: columnar-transposition :fun (:list a) ((p (:list Int))(l(:list a)))
   (:rpipe l
           (arrange-into-columns (length p))
           (do-permutation p)
           concat [reversing "concat" is going to be nontrivial]))

(: n-chunk :fun(:list(:list a))((n Int)(l(:list a)))
   (:case l
          ((:nil)(:mlist) )
          ((_)(:mcons (take n l) (n-chunk n (drop n l))))
          ))

(: Op :type-synonym :args(a) (:fn a ((x a)(y a))))

(: encrypt-cipher-block-chain-for-scanl :fun ivtype
   ((xor (:fn ivtype ((iv ivtype)(c ciphertype))))
    (cipher(:fn ciphertype((p plaintype))))
    (iv ivtype)(p plaintype))
   (xor iv (cipher p)))
(: decrypt-cipher-block-chain :fun (:list plaintype)
   ((unxor(:fn ciphertype((civ ivtype)(iv ivtype))))
    (decipher(:fn plaintype ((c ciphertype))))
    (iv ivtype)(civs(:list ivtype)))
   :forall(plaintype ciphertype ivtype)
   (:case civs
          ((:nil)(:mlist))
          ((:cons(civ)(t))
           (:let
            (: c :fun ciphertype () (unxor civ iv))
            (:mcons
             (decipher c)
             (decrypt-cipher-block-chain unxor decipher civ t))))))
(: index-alphabet :fun Int ((alphabet(:list a))(x a)):context ((Eq a))
   (:rpipe 0 enumFrom (zip alphabet)(lookup x) fromJust))

(: plus-cyclic-alphabet :fun a ((alphabet(:list a))(x a)(y a)):context((Eq a))
   (!! alphabet
       (mod
        (+ (index-alphabet alphabet x)
           (index-alphabet alphabet y))
        (length alphabet))))
(: minus-cyclic-alphabet :fun a ((alphabet(:list a))(x a)(y a)):context((Eq a))
   (!! alphabet
       (mod
        (- (index-alphabet alphabet x)
           (index-alphabet alphabet y))
        (length alphabet))))
(: auto-cipher :fun (:list output)
   ((input-to-iv(:fn ivtype ((p input))))
    (cipher(:fn(:list output) ((iv ivtype)(p(:list input)))))
    (p(:list input)))
   :forall (input ivtype output)
   (:case p
          ((:nil)(:mlist))
          ((:cons(h)(t))
           (:let
            (: iv :fun ivtype () (input-to-iv h))
            (cipher iv t)
            ))))
(: Iv :newtype :args(a) :wrap a :deriving (Show))
(: Plain :newtype :args(a) :wrap a)
(: Cipher :newtype :args(a) :wrap a)

(: cycle-encrypt :fun (Iv Char) ((alphabet String)(iv (Iv Char))(c (Cipher Char)))
   (Iv (plus-cyclic-alphabet alphabet (un-Cipher c) (un-Iv iv))))

(: cycle-decrypt :fun (Cipher Char) ((alphabet String)(civ (Iv Char))(iv (Iv Char)))
   (Cipher (minus-cyclic-alphabet alphabet (un-Iv civ) (un-Iv iv))))

(: id-cipher :fun (:fn(Cipher a)((p(Plain a))))()
   (:rcompose un-Plain Cipher))
(: id-decipher :fun (:fn(Plain a)((c(Cipher a))))()
   (:rcompose un-Cipher Plain))
(: p-to-iv :fun (:fn(Iv a)((p(Plain a))))()
   (:rcompose un-Plain Iv))
(: cbc-encrypt :fun (:fn String((p String)))((alphabet String))
   (:rcompose
    (map Plain)
    (auto-cipher p-to-iv (scanl (encrypt-cipher-block-chain-for-scanl (cycle-encrypt alphabet) id-cipher)))
    (map un-Iv)
    ))
(: cbc-decrypt :fun String((alphabet String)(c String))
   (:case c
          ((:nil)(:mlist))
          :else
          (:mcons (head c)
                  (:rpipe c
                          (map Iv)
                          (auto-cipher id (decrypt-cipher-block-chain (cycle-decrypt alphabet) id-decipher))
                          (map un-Plain)))
          ))

(: division-list :fun (:list Int) ((big Int)(small Int))
   (:let
    (: dm :fun (:tuple Int Int)() (divMod big small))
    (++ (replicate (snd dm) (+ 1 (fst dm)))
        (replicate (- small (snd dm)) (fst dm)))))


(: nm-chunk :fun (:list(:list a)) ((ns(:list Int))(as(:list a)))
   (:case ns
          ((:nil)(:mlist)) ["not checked in length"]
          ((:cons(h)(t))
           ["also, neither take nor drop are checked in length"]
           (:mcons (take h as)
                   (nm-chunk t (drop h as))))))

(: un-columnar-transposition :fun (:list a) ((p(:list Int))(l(:list a)))
   (:rpipe
    l
    (nm-chunk(do-permutation p(division-list (length l) (length p))))
    (do-permutation (inverse-permutation p))
    transpose
    concat
    ))

(: inverse-permutation :fun (:list Int) ((p(:list Int)))
   ["use arrays for better performance"]
   (:rpipe p length enum-zero-size
           (map (index-alphabet p))))

[(: inverse-permutation :fun (:list Int)((p(:list Int)))
   (:rpipe
    (enumFrom 0)
    (zip p)
    (array (:mtuple 0 (:rpipe p length pred)))
    elems))]

(: Template :data (C Char) Upper Lower :deriving (Show))
(: make-template :fun Template ((c Char))
   (:case (isAlpha c)
          (False (C c))
          :else
          (:case (isUpper c)
                 (True Upper)
                 (False Lower))))
(: fill-template :fun String ((t(:list Template))(s String))
   (:case t
          ((:nil)(:mlist))
          ((:cons(h)(t))
           (:let
            (: rest :fun String ((h Char)(s String))
               (:mcons h (fill-template t s)))
            (:case h
                   ((C c)(rest c s))
                   (Lower (rest (head s)(tail s)))
                   (Upper (rest (:rpipe s head toUpper)(tail s))))))))
(: get-lower :fun (:fn String ((s String))) ()
   (:rcompose (filter isAlpha) (map toLower)))
(: wrap-template :fun String ((f(:fn String ((s String))))(s String))
   (:rpipe
    s
    get-lower
    f
    (fill-template (map make-template s))
    ))
(: first-amd :fun String () "Congress shall make no law respecting an establishment of religion, or prohibiting the free exercise thereof; or abridging the freedom of speech, or of the press; or the right of the people peaceably to assemble, and to petition the Government for a redress of grievances.")
(: tfirst :fun String ()
   (:cc (take 270 first-amd) "b."))

(: permutation-32 :fun (:list Int) ()
   (:mlist 19 6 24 27 1 22 2 0 12 11 26 14 17 9 15 3 4 29 7 20 30 5 13 21 16 25 18 23 31 28 10 8))
(: letter-26-permutation :fun String ()
   "bmtisxlqnpwgkuzerfdavhcjyo")

(: sub32 :fun (:fn String ((s String)))()
   (substitution a32lphabet (map (!! a32lphabet) permutation-32)))

(: un-sub32 :fun (:fn String ((s String)))()
   (un-substitution a32lphabet (map (!! a32lphabet) permutation-32)))

(: sub26 :fun (:fn String ((s String)))()
   (substitution alphabet26 letter-26-permutation))

(: un-sub26 :fun (:fn String ((s String)))()
   (un-substitution alphabet26 letter-26-permutation))

(: substitution :fun (:list b) ((as(:list a))(bs(:list b)) (x (:list a))):context ((Eq a))
   (map (do-substitution (zip as bs)) x))
(: un-substitution :fun (:list a) ((as(:list a))(bs(:list b)) (x (:list b))):context ((Eq b))
   (map (do-substitution (zip bs as)) x))

(: perm :fun (:fn (:list a)((l(:list a)))) ()
   (columnar-transposition permutation-32))

(: un-perm :fun (:fn (:list a)((l(:list a))))()
   (un-columnar-transposition permutation-32))

(: cbc :fun (:fn String((s String)))()
   (cbc-encrypt a32lphabet))

(: un-cbc :fun (:fn String((s String)))()
   (cbc-decrypt a32lphabet))

(: run :fun (IO :unit) ((f(:fn String ((s String)))))
   (:rpipe first-amd (wrap-template f) putStrLn))

(: caesar-substitution :fun String ((n Int))
   (map (plus-cyclic-alphabet a32lphabet(!! a32lphabet n)) a32lphabet))
(: caesar :fun (:fn String ((s String))) ((n Int))
   (substitution a32lphabet (caesar-substitution n)))

(: n-iterate :fun a ((n Int)(f(:fn a ((x a))))(x a))
   (!! (iterate f x) n))

(: example :fun (IO :unit)()
   (:do
    (:rpipe latin-alphabet-32 (intersperse (head " ")) putStrLn)
    (:rpipe permutation-32 (map show) unwords putStrLn)
    (putStrLn first-amd)
    (run (caesar 2))
    (run sub32)
    (run perm)

    (:rpipe first-amd get-lower bacon-sep unwords putStrLn)
    (run (:rcompose bacon perm un-bacon))
    (run cbc)
    (run (:rcompose cbc sub32))
    (putStrLn "=========================")
    (putStrLn tfirst)
    (run (:rcompose sub32 bacon perm un-bacon))
    (:rpipe tfirst (wrap-template (:rcompose sub32 bacon perm un-bacon)) putStrLn)
    (putStrLn "=========================")
    (:dlet
     (: x :fun (:fn String ((s String)))()
	(:rcompose sub32 bacon perm un-bacon cbc))
     (: y :fun (:fn String ((s String)))()
	(:rcompose un-cbc bacon un-perm un-bacon un-sub32))
     )

    (run x)
    (:rpipe tfirst (wrap-template x) putStrLn)

    (putStrLn "=========================")
    (run (:rcompose x x x))
    (:rpipe tfirst (wrap-template (:rcompose x x x)) putStrLn)
    (putStrLn "=========================")
    (run (:rcompose x x x y y y))
    (run (n-iterate 3 x))
    (run (n-iterate 1000000 x))

    ))