■

ちょっと複雑な例になると手でやるのが急速にしんどくなるので、hylo-formに変換するのは簡単そうだし自分で書くかと思って、OnoueのD論読んでたら、『説明を簡略化するため，用いるデータ構造は単一再帰のみに，再帰関数は相互再帰を含まないように限定することにする．これは標準的な組化手法によって，相互再帰に定義された関数は相互再帰を含まない形に変換できることが知られているので，一般性を損ねることはない．さらに入れ子構造になったcase 式はそれを平坦化(flatten) したものに変換済であることを仮定する』と書いてあった。う゛ぉ゛おいぃ゛いいいいい!相互再帰はとりあえずいいとして、入れ子になったcase式の平坦化ってどうやんねん

とりあえず、derivationだけ書いた。かなり適当というか、余りに適当すぎるというか･･･適当ってレベルじゃねえぞ！internされてないsymbolというか、identifierをgetしたいわけだけど、どうすればいいねん、という課題。安西先生、gensymが欲しいです。とりあえず、普通のHaskellでは、変数名は%から始まることはないので、先頭に%付けとけば、名前の衝突は回避できるか〜とか、アバウトな感覚で。もっといい方法がありそうというか、こういう処理は、コンパイラ書くときには必須なので、GHCのソースみればよい気が。確かrenameなんちゃらとかあったよ。そこまで分かってながら、面倒なので調べてない。Schemeで書き直そうかしら

module HyloFusion where
import Data.List(union,find)
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef 

--syntax of HyloCore language
data Term = 
   Var String  -- variable
 | Lit Literal -- literal
 | Tuples [Term] 
 | Lam Args Term
 | Let String Term Term 
 | Case Term [(Pat,Term)] 
 | FApp String [Term]
 | CApp String [Term] -- constructor application
 | App Term Term -- application(general) 
 | Juncs [Term]  -- junc
 | Tags (Int , Term) 
    deriving (Eq,Show)

data Literal =    --適宜修正
    HfUnit
  | HfBool Bool 
  | HfInteger Integer 
  | HfChar Char
  | HfDouble Double 
     deriving (Eq,Show)

data Args = Argv String | Vars [String] deriving (Eq,Show)
data Pat = PVar String | PTuples [Pat] | CPat String [Pat] deriving (Eq,Show)
data HyloForm = Hylo [String] Term Term Term deriving (Eq,Show)

fst3 (x,_,_) = x
snd3 (_,x,_) = x
third3 (_,_,x) = x

count = newIORef 0

hyloDeriveA :: String -> Term -> [String] -> HyloForm
hyloDeriveA name def@(Lam var (Case t0 body)) vlist  =
  case var of
   (Vars s) -> Hylo (init s) phi idTerm (psi1 s)
   (Argv s) -> Hylo [] phi idTerm (psi2 s)
  where
   idTerm = (Lam (Argv "x") (Var "x")) -- identity
   derives = map (\t -> hyloDeriveD name t [] vlist) (map snd body)
   toVars t = Vars $ map (\e -> case e of (Var v)->v) t
   phi = 
    Juncs (map (\k -> (Lam (toVars ((fst3 k)++(map fst (snd3 k))))) (third3 k)) derives)
   psi1 s = Lam (Argv (last s)) (Case t0 psiBody)
   psi2 s = Lam (Argv s) (Case t0 psiBody)
   psiBody =
    zip (map fst body) $
      map Tags (zip [1..(length body)] 
                    (map (\k-> Tuples ((fst3 k)++(map snd (snd3 k)))) derives))

hyloDeriveD :: String -> Term -> [String] -> [String] ->([Term],[(Term,Term)],Term)
hyloDeriveD name expr sl sg =
 case expr of 
   (Var v) -> if (memberp v sg || memberp v sl) 
               then ([],[],(Var v)) 
               else ([(Var v)],[],(Var v))
   (Lit v) -> ([],[],(Lit v)) 
   (Tuples ts) -> 
     (\k -> (unions (map fst3 k) , unions (map snd3 k),Tuples (map third3 k)))
     (map (\t -> hyloDeriveD name t sl sg) ts)
   (Lam vs t) -> 
     (\k-> (fst3 k , snd3 k , Lam vs (third3 k)))
     (hyloDeriveD name t (union sl ((\x-> (case x of (Vars v)->v)) vs)) sg)
   (Let v t1 t0) -> 
     (\k0 k1 -> 
       (union (fst3 k1) (fst3 k0) ,
        union (snd3 k1) (snd3 k0) ,
        Let v (third3 k1) (third3 k0)))
     (hyloDeriveD name t0 (v:sl) sg) (hyloDeriveD name t1 sl sg)
   (Case t0 ps) ->
     (\k ks -> 
        (union (fst3 k) (unions (map fst3 ks)),
         union (snd3 k) (unions (map snd3 ks)),
         Case (third3 k) (zip (map fst ps) (map third3 ks))))
     (hyloDeriveD name t0 sl sg) 
     (map (\p-> hyloDeriveD name (snd p) (union sl (patVars (fst p))) sg) ps)
   (FApp v ts) ->   --微妙に手抜き
    if (v==name) 
     then (\nv -> ([],[(nv,last ts)],nv)) (Var (unsafePerformIO newVar))
     else (\k ks -> 
             (union (fst3 k) (unions (map fst3 ks)),
              union (snd3 k) (unions (map snd3 ks)),
              FApp ((\e->case e of (Var v)->v) (third3 k)) (map third3 ks)))
          (hyloDeriveD name (Var v) sl sg) (map (\t->hyloDeriveD name t sl sg) ts)
   (CApp c ts) -> 
     (\k -> (unions (map fst3 k) , unions (map snd3 k) , CApp c (map third3 k)))
     (map (\t -> hyloDeriveD name t sl sg) ts)
   (App t0 t1) ->
     (\k0 k1 -> 
       (union (fst3 k1) (fst3 k0) ,
        union (snd3 k1) (snd3 k0) ,
        App (third3 k0) (third3 k1)))
     (hyloDeriveD name t0 sl sg) (hyloDeriveD name t1 sl sg)
 where
  newVar = do{c<-count;
              n<-readIORef c;
              modifyIORef c (+1);
              return ("%tekitoh"++(show n))} --色々まずいかも
  memberp e ls = case find (e==) ls of {(Just _)->True;Nothing->False}
  unions :: (Eq a)=>[[a]]->[a]
  unions = foldr union []
  patVars (PVar str) = [str]
  patVars (PTuples pats) = unions (map patVars pats)
  patVars (CPat s pats) =  unions (map patVars pats)


--sum = \x -> case x of {Nil->0;(Cons a as)->((+) a (sum as))}
--hyloDeriveA "sum" sumRec ["+"]
sumRec = (Lam
          (Argv "x")
          (Case (Var "x")
            [( (CPat "Nil" []) , 
               (Lit (HfInteger 0)) ) ,
             ( (CPat "Cons" [(PVar "a"),(PVar "as")]) , 
	       (FApp "+" [(Var "a"),(FApp "sum" [(Var "as")])]) )]))

課題
・適当な部分を修正してバグをとる
・hylo-reconstructionを書く
・hylo-formの展開も実装する(HyloForm -> Term)
・case式の平坦化
・パーサーを書く
・いまだにParsecがよくわからない
・Juncsってださいよね
・できれば、GHC Coreに組み込めるように、すり合せを
・やることが多い
・やる気がでない