スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

F#で入門 コンパイラ、インタプリタ編 Logo風言語再び

 今回は前回作ったクラスを利用して次のようなソフトを作ってみます。 


1013-1.jpg
 
このプログラミング言語の定義は以前やったものと同じですが、次のような命令を付け加えてあります。 
 
penRed...............penの色を赤にする 
penBlack.............penの色を黒にする 
penBlue..............penの色を黒にする 
penUp................penを持ち上げる(goしても、ペンの位置が変わるだけで描画しない。) 
penDown..............penをおろす 
pen1.................penの太さを1にする 
pen2.................penの太さを2にする 
pen3.................penの太さを3にする 
goAndSleep 自然数....描画してから数の分だけ休む 
length 自然数........一歩の長さを変える 
  
 トークンルールと構文規則を前回作ったLL1TokenizeAndParseクラスに与えてインスタンスを生成します。 
 (クラスの説明は前回分を参照してください。) 
  
 let tnR = 
        [("NUM","\d+"); 
        ("PROGRAM","program"); 
        ("REPEAT","repeat"); 
        ("GO","go"); 
        ("RIGHT","right"); 
        ("LEFT","left"); 
        ("END","end"); 
        ("PENRED","penRed"); 
        ("PENBLACK","penBlack"); 
        ("PENBLUE","penBlue"); 
        ("PENDOWN","penDown"); 
        ("PENUP","penUp"); 
        ("PEN1","pen1"); 
        ("PEN2","pen2"); 
        ("PEN3","pen3"); 
        ("GOANDSLEEP","goAndSleep"); 
        ("LENGTH","length") 
        ] 
 
let grammersStrLst = 
   ["1: Program = PROGRAM CommandList"; 
    "2: CommandList = Command END"; 
    "3: Command = EPSILON"; 
    "4: Command = Command2 Command"; 
    "5: Command2 = RepeatCommand"; 
    "6: Command2 = PrimitiveCommand"; 
    "7: RepeatCommand = REPEAT NUM CommandList"; 
    "8: PrimitiveCommand = GO"; 
    "9: PrimitiveCommand = RIGHT"; 
    "10: PrimitiveCommand = LEFT"; 
    "11:PrimitiveCommand =PENRED"; 
    "12:PrimitiveCommand = PENBLACK"; 
    "13:PrimitiveCommand = PENBLUE"; 
    "14:PrimitiveCommand = PENUP"; 
    "15:PrimitiveCommand = PENDOWN" 
    "16:PrimitiveCommand = PEN1"; 
    "17:PrimitiveCommand = PEN2"; 
    "18:PrimitiveCommand = PEN3"; 
    "19: PrimitiveCommand = GOANDSLEEP NUM"; 
    "20: PrimitiveCommand = LENGTH NUM"; 
 
    ] 
 
let tp = new LL1TokenizeAndParse (tnR,grammersStrLst) 
  
 これでtpにソースを与えてtp.GetEBASTtree ソース とすれば具象構文木が手にはいりますので、今回はこの木を使って関数を作り上げて、これを利用するという方針でやってみたいと思います。 
  
 penを動かしながら描写していくわけなので、変化するものとして 
 (1)Graphics(これは変化しないが、描写先として渡す) 
 (2)Pen(太さ、幅が変わる可能性あり) 
 (3)座標 
 (4)向き 
 (5)一歩の幅 
 (6)penがdown状態かup状態か 
 があるので、これをタプルにしたものをstateというtype名で定義しておきます。 
  
/////////////Graphics//Pen//座標///向き//一歩の幅//oenがOnか 
type state = Graphics*Pen*(int*int)*int*int*bool 
  
型がstate->state型の関数を具象構文木を利用して作り上げます。 
 
問題の関数を作り上げる関数の一部は次のようになってます。 
let rec makeUpFunc (eb:embodyST)  = 
    match eb with 
    //0: Z = Program EOF 
    |Node(0,_,pro::_)      
        ->  makeUpFunc pro  
    //1  Program = PROGRAM CommandList 
    |Node(1,_,_:: cl :: _ )      
        -> makeUpFunc cl 
    //2  CommandList = Command END 
    |Node(2,_,cd ::_ )     
        -> makeUpFunc cd 
    //3  Command = ε 
    |Node(3,_,_ )     
        -> (fun s -> s) //引数をそのまま返す  idでもよい 
    //4  Command = Command2 Command 
    |Node(4,_,cd2::cd::_)     
        -> (makeUpFunc cd2) >> (makeUpFunc cd) 
 
 中略 
  
  
    //8  PrimitiveCommand = GO 
    |Node(8,_,_)      
        -> (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let (nextXPos,nextYPos) = getNextPos dir (x,y) length 
               if penUpOrDown = true then 
                    let oldPoint = new Point(x,y) 
                    let newPoint = new Point (nextXPos,nextYPos) 
                    gr.DrawLine(pen,oldPoint,newPoint) 
               (gr,pen, (nextXPos,nextYPos),dir,length,penUpOrDown) 
            ) 
 
 
あと少し厄介なのがrepeatに対応する部分ですが、 
 
> let makeUpRepeatFunc (count:int) (f:state->state) = 
    let rec rf (c:int) (limit:int) (st:state) = 
        if limit = c then  st 
        else rf (c + 1) limit (f st) 
    rf 0 count;; 
 
val makeUpRepeatFunc : int -> (state -> state) -> (state -> state) 
 
としておけばintとstate->state型の関数を渡すと、その回数繰り返すstate->state型の関数を得ることができるので、これを利用して 
 
    //7  RepeatCommand = REPEAT NUM CommandList 
    |Node(7,_,_::Leaf(intStr)::cl::_)     
        ->  let repeatNum = System.Int32.Parse(intStr.Img) 
            makeUpRepeatFunc repeatNum (makeUpFunc cl)             
 
と定義しておきます。 
 
ではこの関数部分を全部載っけておきます。 
 
let rec makeUpFunc (eb:embodyST)  = 
    match eb with 
    //0: Z = Program EOF 
    |Node(0,_,pro::_)      
        ->  makeUpFunc pro  
    //1  Program = PROGRAM CommandList 
    |Node(1,_,_:: cl :: _ )      
        -> makeUpFunc cl 
    //2  CommandList = Command END 
    |Node(2,_,cd ::_ )     
        -> makeUpFunc cd 
    //3  Command = ε 
    |Node(3,_,_ )     
        -> (fun s -> s) //引数をそのまま返す  idでもよい 
    //4  Command = Command2 Command 
    |Node(4,_,cd2::cd::_)     
        -> (makeUpFunc cd2) >> (makeUpFunc cd) 
    //5  Command2 = RepeatCommand 
    |Node(5,_,rc::_)      
        -> makeUpFunc  rc 
    //6  Command2 = PrimitiveCommand 
    |Node(6,_,pc::_)     
         -> makeUpFunc pc 
    //7  RepeatCommand = REPEAT NUM CommandList 
    |Node(7,_,_::Leaf(intStr)::cl::_)     
        ->  let repeatNum = System.Int32.Parse(intStr.Img) 
            makeUpRepeatFunc repeatNum (makeUpFunc cl)             
   //8  PrimitiveCommand = GO 
    |Node(8,_,_)      
        -> (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let (nextXPos,nextYPos) = getNextPos dir (x,y) length 
               if penUpOrDown = true then 
                    let oldPoint = new Point(x,y) 
                    let newPoint = new Point (nextXPos,nextYPos) 
                    gr.DrawLine(pen,oldPoint,newPoint) 
               (gr,pen, (nextXPos,nextYPos),dir,length,penUpOrDown) 
            ) 
    //9  PrimitiveCommand = RIGHT 
    |Node(9,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let nextDir = turnRight dir 
               (gr,pen, (x,y),nextDir,length,penUpOrDown) 
            )  
    //10 PrimitiveCommand = LEFT        
    |Node(10,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let nextDir = turnLeft dir 
               (gr,pen, (x,y),nextDir,length,penUpOrDown) 
            )  
    //11:PrimitiveCommand =PENRED 
    |Node(11,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Color <- Color.Red 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //12:PrimitiveCommand = PENBLACK 
    |Node(12,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Color <- Color.Black 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //13:PrimitiveCommand = PENBLUE 
    |Node(13,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Color <- Color.Blue 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //14:PrimitiveCommand = PENUP 
    |Node(14,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               (gr,pen, (x,y),dir,length,false) 
            )  
   //15:PrimitiveCommand = PENDOWN"  
    |Node(15,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               (gr,pen, (x,y),dir,length,true) 
            ) 
    //16:PrimitiveCommand = PEN1 
    |Node(16,_,_)    
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Width <- 1.0f 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //17:PrimitiveCommand = PEN2 
    |Node(17,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Width <- 2.0f 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
 
            ) 
    //18:PrimitiveCommand = PEN3 
    |Node(18,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Width <- 3.0f 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
 
            ) 
    //19: PrimitiveCommand = GOANDSLEEP NUM 
    |Node(19,_,_:: Leaf(intStr)::_)    
        -> let sleepTime = System.Int32.Parse(intStr.Img) 
           (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let (nextXPos,nextYPos) = getNextPos dir (x,y) length 
               if penUpOrDown = true then 
                    let oldPoint = new Point(x,y) 
                    let newPoint = new Point (nextXPos,nextYPos) 
                    gr.DrawLine(pen,oldPoint,newPoint) 
               System.Threading.Thread.Sleep sleepTime  
               (gr,pen, (nextXPos,nextYPos),dir,length,penUpOrDown) 
            )         
     //20:  PrimitiveCommand = LENGTH NUM 
    |Node(20,_,_:: Leaf(intStr)::_)   
        -> let newLength = System.Int32.Parse(intStr.Img) 
           (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               (gr,pen,(x,y),dir,newLength,penUpOrDown) 
            )         
    
    |_ -> failwith "RunTime error" 
 
これでmakeUpFunc 具象構文木 としてやれば、state->state型の関数が手にはいるので、 
初期値を与えてやれば、描画してくれます。 
 
フォームデザインはいつものようにSimpleFormConverterを利用して作成しています。 
 
ちなみに実行画面のサンプルのコードは以下のようなものです。(一行にかいてもよいのですが、読みやすさのために整形しています。) 
 
program  
          length 30  
          repeat 4 
              right 
              repeat 4  
                 repeat 3  
                        penBlue go right  penRed goAndSleep 100 left  
                 end  
                 right  
             end 
          end  
end 
 
 
全コードは以下の通りです。 
(コピペしてすぐ実行できるように、LL1TokenizeAndParse関連コードも含まれています。このソフト用に書いたコードは250行ほどです。) 
 open System    
open System.Text.RegularExpressions 
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////// 
 
//文法定義のエラー 
exception MyGramExcp of string 
 
let STR_EPS ="EPSILON" 
 
//引数分の空白文字を作る補助関数 
let spaceStr(i) =  
    let sb = new System.Text.StringBuilder() 
    let rec addSpace count = 
        if count = i then sb.ToString() 
        else 
            sb.Append(" ") |> ignore 
            addSpace (count + 1) 
    addSpace 0  
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////// 
 
type Token(kind:string,img:string,row:int,col:int) = 
    member this.Kind = kind 
    member this.Img = img 
    member this.Row = row 
    member this.Col = col 
 
    override this.ToString() = 
        sprintf "[%s %s (%d,%d)] " kind img row col 
 
//一行をトークン化したときの結果用の型 
type TokenizeOneLineResult = 
    |TOLSuccess of list<Token> 
    |TOLFail of int*int //トークン化失敗したときの行と列 
 
    member this.IsSuccess () = 
        match this with 
        |TOLSuccess(_) -> true 
        | _ -> false 
 
 
 
//具象構文木 
type embodyST = 
    |EPS_Leaf of Token //tokenは存在しないので、εの直後のtokenを与える 
    |Leaf of Token  
    |Node of (int* string * list<embodyST>) //intは構文規則番号,stringは "(1, "Program", ["DeclStmts"; "PrintStmts"])"等 
 
    //表示用 
    member this.dispStr (inc :int)  = //inc = インシデント 
            match this with 
            |EPS_Leaf (token) 
                -> spaceStr(inc) +  "ε" + (sprintf "(%d,%d)の前" token.Row token.Col ) + "\r\n" 
            |Leaf(token) 
                -> spaceStr(inc) +  token.ToString() + "\r\n"  
            |Node(index,str,lst)  
                -> spaceStr(inc) + (sprintf "(%d)" index) + str + "\r\n"  
                   + List.fold (fun state (ele:embodyST) -> state + (ele.dispStr (inc + 4)) ) "" lst  
 
 
 
type LL1TokenizeAndParse (inDefLst:list<string*string>, inStrLst:list<string>) = 
 
    let initStrLst = "0:Z = Program EOF" :: inStrLst 
    let initDefLst =  ("EOF","EOF"):: inDefLst 
 
    let makeTokenizeRules (inDefLst:list<string*string>) = 
        inDefLst 
            |> List.map(fun (name,rgText) ->(name,(new Regex ( @"^(?<sPart>\s*)(?<parts>" + rgText + @")")))) 
 
    let tokenizeTopPart (textPart:string) (trl:list<string*Regex>) (row:int) (col:int) = 
        trl 
          |>List.fold (fun (curToken:Token,curLongestLength:int) (name,rg) -> 
                            let wholeMatch = rg.Match(textPart) 
                            let partMatch = wholeMatch.Groups.["parts"]  //必要な部分 
                            let sPartMatch = wholeMatch.Groups.["sPart"] //先頭の空白部分 
                            if wholeMatch.Value.Length > curLongestLength then //最長マッチ 
                                (new Token(name,partMatch.Value,row, col + sPartMatch.Value.Length),wholeMatch.Value.Length ) 
                            else 
                                (curToken,curLongestLength) 
                      ) 
                      (new Token("","",0,0),0) 
 
 
    let tokenizeOneLine (inDefLst:list<string*string>) (inRow:int) (inOneLineStr:string) = 
        let trs = makeTokenizeRules inDefLst 
        let rec tokenizeOneLineSub (curCol:int) (remainStr:string) res = 
            if remainStr.Trim().Length = 0 then 
                TOLSuccess(List.rev res) 
            else 
               let (slicedToken,length) = tokenizeTopPart remainStr trs inRow curCol 
               if length = 0 then 
                    let topBlankNum = remainStr.Length - remainStr.TrimStart().Length 
                    TOLFail(inRow,curCol+topBlankNum) 
               else 
                  tokenizeOneLineSub (curCol + length) (remainStr.Substring(length)) (slicedToken::res)        
        tokenizeOneLineSub 1 inOneLineStr [] 
 
    let tokenizer  (source:list<string>) = 
        let oneLineTokenizer = tokenizeOneLine initDefLst 
        let isTOLSuccess (x:TokenizeOneLineResult) = 
            match x with 
            |TOLSuccess(_) -> true 
            |_             -> false 
        let sucLst,failLst = 
            source 
            |>List.map (fun str -> str.TrimEnd()) 
            |>List.mapi (fun i str -> oneLineTokenizer (i+1) str ) 
            |>List.partition (fun tr -> tr.IsSuccess () ) 
        if failLst.Length > 0 then  
            failwith (sprintf "%A" failLst) 
        else  
            sucLst 
              |>List.map (fun tolr -> match tolr with 
                                         |TOLSuccess(tol) -> tol 
                                         | _ -> failwith "error" //これは起こらない 
                         ) 
              |>List.fold (fun s lst -> s @ lst) [] 
         
    let splitOneLineGram (inStr:string)= 
        let (lhdIndex,rhd) =  
            match inStr.Split([|':'|]) with 
            [|mlhd;mrhd|]  ->  (mlhd.Trim(),mrhd) 
            | _             ->  raise <| MyGramExcp(inStr)  
        let (lhd,rhd2) = 
            match rhd.Split([|'='|]) with 
            |[|mlhd;mrhd|]  ->  (mlhd.Trim(),mrhd) 
            | _             ->  raise <| MyGramExcp(inStr)  
        let rhdElems =  
            rhd2.Split([|' '|]) 
                |> List.ofArray 
                |> List.map (fun s -> s.Trim()) 
                |> List.filter (fun s -> s <> "") 
        (System.Int32.Parse(lhdIndex),lhd,rhdElems) 
 
 
    let getNTN_TN__Sets (inStrLst:list<string>) = 
        let (sumUpLhdSet,sumUpRhdSet) = 
            inStrLst 
                |> List.map splitOneLineGram 
                |> List.fold (fun (acclh,accrh)  (_,lhd,rhdLst) -> (lhd :: acclh,rhdLst @ accrh)) ([],[]) 
                |> (fun (hdLst,rhLst) -> (Set.ofList hdLst, Set.ofList rhLst)) 
        (sumUpLhdSet,sumUpRhdSet - sumUpLhdSet - (Set.ofList [STR_EPS])) 
 
    let (ntnSet,tnSet) =  getNTN_TN__Sets initStrLst   
 
 
    let isNullableToken ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)(inTokenName:string) = 
        if inTokenName = STR_EPS then  
             true 
        elif Set.contains inTokenName in_tn then 
             false 
        else 
            in_ntnNullableMap.[inTokenName] 
 
    let isNullableTokenLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)(inTokenNameLst:list<string>) = 
          List.forall (isNullableToken (in_ntn,in_tn) in_ntnNullableMap )inTokenNameLst //リスト中のすべてのtokenがnullableか 
           
    let isNullableTokenLstLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)(inTokenNameLstLst:list<list<string>>) = 
          List.exists (isNullableTokenLst (in_ntn,in_tn) in_ntnNullableMap ) inTokenNameLstLst//リスト中のどれかのtokenリストがnullableか 
 
    let grams = initStrLst 
                    |> List.map splitOneLineGram 
                    |> List.map (fun (_,lh,rhEles) -> (lh,rhEles)) //[("Program",["DeclStmts";"PrintStmts"]);("DeclStmts",["VAR";"SEMI"])] 
  
    let getNTN_NullableMap (inStrLst:list<string>) = 
     
    
        let rec getNTN_NullableMapSub (inOldNullableMap:Map<string,bool>) (count:int) =  
            let nextNullableMap = 
                ntnSet 
                    |> Set.fold (fun stateMap ele -> 
                                    let targetGramsLstLst = 
                                        grams 
                                            |>List.filter (fun (ntnName,_) -> ntnName = ele) 
                                            |>List.map (fun (_,lst) -> lst) 
                                    let thisEleNullable = 
                                        isNullableTokenLstLst(ntnSet,tnSet) inOldNullableMap targetGramsLstLst 
                                    Map.add ele thisEleNullable stateMap 
                                 ) 
                                 Map.empty 
            if count > 10000 then 
                failwith "count error" 
            elif nextNullableMap = inOldNullableMap then 
                nextNullableMap 
            else 
                getNTN_NullableMapSub nextNullableMap (count + 1) 
     
        let initNullableMap = 
                    ntnSet 
                        |> Set.map (fun ele -> (ele,false)) 
                        |> Map.ofSeq 
     
        getNTN_NullableMapSub initNullableMap 0 
 
 
    let ntnNullableMap = getNTN_NullableMap initStrLst 
 
 
    let getFirstSetOfToken ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnFirstSetMap:Map<string,Set<string>>)(inTokenName:string) = 
        if inTokenName = STR_EPS then  
             Set.empty 
        elif Set.contains inTokenName in_tn then 
             Set.ofList ([inTokenName]) 
        else 
            in_ntnFirstSetMap.[inTokenName] 
 
    let getFirstSetOfTokenLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>) 
                               (in_firstSetMap:Map<string,Set<string>>) (inTokenNameLst:list<string>) = 
          let isNullableTokenPartApply = isNullableToken (in_ntn,in_tn) in_ntnNullableMap    
       
          let rec getFirstSetOfTokenLstSub (tokenLst:list<string>)  = 
            match tokenLst with 
            |[] -> Set.empty 
            |hd::tl when isNullableTokenPartApply hd -> (getFirstSetOfToken (in_ntn,in_tn) in_firstSetMap hd) + (getFirstSetOfTokenLstSub tl) 
            |hd::tl                                  -> (getFirstSetOfToken (in_ntn,in_tn) in_firstSetMap hd) 
 
          getFirstSetOfTokenLstSub inTokenNameLst 
 
    let getFirstSetOfTokenLstLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>) 
                              (in_firstSetMap:Map<string,Set<string>>) (inTokenNameLstLst:list<list<string>>) =   
 
        let getFirstSetOfTokenLstPartApply = getFirstSetOfTokenLst (in_ntn,in_tn) in_ntnNullableMap in_firstSetMap 
     
        List.fold (fun acc ele -> acc + (getFirstSetOfTokenLstPartApply ele)) Set.empty inTokenNameLstLst 
 
    let getNTN_FirstMap  (inStrLst:list<string>) = 
     
        let FisrtSetOfTokenLstLstPA = getFirstSetOfTokenLstLst (ntnSet,tnSet) ntnNullableMap 
     
        let rec getNTN_FirstMapSub (inOldFirstMap:Map<string,Set<string>>) (count:int) =  
            let nextFirstMap = 
                ntnSet 
                    |> Set.fold (fun stateMap ele -> 
                                    let targetGramsLstLst = 
                                        grams 
                                            |>List.filter (fun (ntnName,_) -> ntnName = ele) 
                                            |>List.map (fun (_,lst) -> lst) 
                                    let thisEleFisrtSet = 
                                         FisrtSetOfTokenLstLstPA inOldFirstMap targetGramsLstLst 
                                    Map.add ele thisEleFisrtSet stateMap 
                                 ) 
                                 Map.empty 
            if count > 10000 then 
                failwith "count error" 
            elif nextFirstMap = inOldFirstMap then 
                nextFirstMap 
            else 
                getNTN_FirstMapSub nextFirstMap (count + 1) 
     
        let initFirstMap = 
                    ntnSet 
                        |> Set.map (fun ele -> (ele,Set.empty)) 
                        |> Map.ofSeq 
     
        getNTN_FirstMapSub initFirstMap 0 
 
    let ntnFirstMap = getNTN_FirstMap initStrLst 
     
    let getAfterTokens (inStr:string) ((lhdStr,rhStrLst):string*list<string>) = 
        let rec getAfterTokensSub strLst res = 
            match strLst with 
            |hd::tl when hd = inStr -> getAfterTokensSub tl ((tl,lhdStr)::res) 
            |hd::tl                 -> getAfterTokensSub tl res 
            | [] -> res 
        getAfterTokensSub rhStrLst [] 
     
    let getNTN_FollowMap  (inStrLst:list<string>) = 
        let isNullableTokensLstPA (tokenLst:list<string>) = isNullableTokenLst (ntnSet,tnSet) ntnNullableMap tokenLst 
        let getFirstSetOfTokenLstPA (tokenLst:list<string>) = getFirstSetOfTokenLst (ntnSet,tnSet) ntnNullableMap  ntnFirstMap tokenLst 
  
        let rec getNTN_FollowMapSub (inOldFollowMap:Map<string,Set<string>>) (count:int) =  
           let getFollowSet (afterTokens:list<string>,ntnName:string) = 
                    if isNullableTokensLstPA afterTokens then 
                        (getFirstSetOfTokenLstPA afterTokens) + (inOldFollowMap.[ntnName]) 
                    else 
                        (getFirstSetOfTokenLstPA afterTokens)                 
           let nextFollowMap = 
                ntnSet 
                    |> Set.fold (fun stateMap ele -> 
                                    let includeEleGrams = 
                                        grams 
                                          |> List.fold (fun state2 (ntnName2,tokenLst) 
                                                            -> state2 @ (getAfterTokens ele (ntnName2,tokenLst))) 
                                                        [] 
                                                     
                                    let followSet = 
                                        includeEleGrams 
                                          |> List.fold (fun (state3:Set<string>) (afterTokens,ntnName) -> 
                                                        state3 + (getFollowSet (afterTokens,ntnName))) 
                                                        Set.empty 
                                    Map.add ele followSet stateMap 
                                 ) 
                                 Map.empty 
           if count > 10000 then 
                failwith "count error" 
           elif nextFollowMap = inOldFollowMap then 
                nextFollowMap 
           else 
                getNTN_FollowMapSub nextFollowMap (count + 1) 
 
 
        let initFollowMap = 
                    ntnSet 
                        |> Set.map (fun ele -> (ele,Set.empty)) 
                        |> Map.ofSeq 
     
        getNTN_FollowMapSub initFollowMap 0 
     
    let ntnFollowMap = getNTN_FollowMap initStrLst 
 
    let gramsWithIndex = initStrLst 
                            |> List.map splitOneLineGram 
                            |> List.map (fun (index,lh,rhEles) -> (index,(lh,rhEles)))  
 
    let getNTN_DirectorMap  (inStrLst:list<string>) = 
        let isNullableTokensLstPA (tokenLst:list<string>) = isNullableTokenLst (ntnSet,tnSet) ntnNullableMap tokenLst 
        let getFirstSetOfTokenLstPA (tokenLst:list<string>) = getFirstSetOfTokenLst (ntnSet,tnSet) ntnNullableMap  ntnFirstMap tokenLst 
     
        let getNTN_DirectorSet (inHh:string,inRhEles:list<string>) = 
            if isNullableTokensLstPA inRhEles then 
                (getFirstSetOfTokenLstPA inRhEles) + ntnFollowMap.[inHh] 
            else 
                (getFirstSetOfTokenLstPA inRhEles) 
 
        gramsWithIndex 
            |> List.map (fun (index,(lh,rhEles)) -> (index, getNTN_DirectorSet (lh,rhEles))) 
            |> Map.ofList              
 
    let directorMap = getNTN_DirectorMap initStrLst 
 
    let getOneToOneParsingRelation (inStrLst:list<string>) = 
        let relationBetweenIndexAndNTN_namdAndDirecSetList 
            = [ for (index,(lh,rhEles)) in gramsWithIndex do 
                    for direcEle in directorMap.[index] do 
                        yield (index,lh,direcEle) ] 
 
        let ParsingRelation 
            = relationBetweenIndexAndNTN_namdAndDirecSetList 
                |> List.fold (fun (stateMap:Map<string*string,Set<int>>)  (index,lh,direcEle)  ->       
                                        let tf = Map.tryFind (lh,direcEle) stateMap 
                                        match tf with 
                                        |Some(oldSet) -> Map.add (lh,direcEle) (oldSet + (Set.ofList [index])) stateMap 
                                        |None         -> Map.add (lh,direcEle) (Set.ofList [index]) stateMap 
                             ) 
                             Map.empty               
         
        let OneToOneParsingRelation 
            = ParsingRelation 
                |> Map.map (fun (ntnName,direcEle) intSet ->  
                                    if Set.count intSet > 1 then raise (MyGramExcp "衝突しているのでLL(1)解析できません") 
                                    else 
                                       match (List.ofSeq intSet) with 
                                       | [] -> failwith "neverOccurable Error" // 起こらない 
                                       | h::[] -> h 
                                       | _ ->  failwith "neverOccurable Error" // 起こらない 
                           )          
 
        OneToOneParsingRelation 
 
     
    let getIndexGRmap (inStrLst:list<string>) = 
        inStrLst 
            |> List.map splitOneLineGram  
            |> List.map (fun (index,_,gramLst) -> (index,gramLst)) 
            |> Map.ofList 
 
 
    let rec makeEmbodyST ((tntSet:Set<string>),(ntSet:Set<string>))  
                         (prMap:Map<(string * string),int>) (iGmap:Map<int,string list>) 
                         ((remainToken:list<Token>),(remainGRM:list<string>),(acc:list<embodyST>)) = 
        match remainToken,remainGRM with 
        |[],_ -> ([],[],acc) 
        //一つの構文要素終了時 
        |remt,[]    -> (remt,[],acc)  
        //εの場合 
        |hdt::tlt,hdg::tlg  when hdg = STR_EPS  
                    -> makeEmbodyST (tntSet,ntSet) prMap iGmap (remainToken,tlg,acc @ [EPS_Leaf(hdt)])  
        //終端記号 
        |hdt::tlt,hdg::tlg  when hdt.Kind = hdg 
                    -> makeEmbodyST (tntSet,ntSet) prMap iGmap  (tlt,tlg,acc @ [Leaf(hdt)]) 
        //非終端記号 
        |hdt::tlt,hdg::tlg   
                   -> let foundPRIndex = Map.tryFind (hdg,hdt.Kind) prMap 
                      match foundPRIndex with 
                      |Some(i) -> let shouldUseGram = iGmap.[i] 
                                  let (remT,remG,underNodes) = makeEmbodyST (tntSet,ntSet) prMap iGmap (remainToken,shouldUseGram,[]) 
                                  //上の行でremGは[]として返ってくる 
                                  makeEmbodyST (tntSet,ntSet) prMap iGmap (remT,tlg, acc @ [Node(i,hdg,underNodes)]) 
                               
                      |None    -> raise (MyGramExcp (sprintf "%sで文法エラー" (hdt.ToString()))) 
 
 
 
    member this.GetTokens (sourceLst:list<string>) =   
        tokenizer sourceLst   
 
    member this.GetEBASTtree (sourceLst:list<string>) =   
        let forTokenizedLst =  sourceLst @ ["EOF"] 
        let tokens = tokenizer forTokenizedLst 
        let relMap = getOneToOneParsingRelation initStrLst 
        let indexGRmap = getIndexGRmap initStrLst 
        let (_,_,madeTree) = makeEmbodyST (ntnSet,tnSet) relMap indexGRmap (tokens,["Z"],[]) 
        List.head madeTree 
 
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////// 
open System.Windows.Forms    
open System.Drawing   
 
let tnR = 
        [("NUM","\d+"); 
        ("PROGRAM","program"); 
        ("REPEAT","repeat"); 
        ("GO","go"); 
        ("RIGHT","right"); 
        ("LEFT","left"); 
        ("END","end"); 
        ("PENRED","penRed"); 
        ("PENBLACK","penBlack"); 
        ("PENBLUE","penBlue"); 
        ("PENDOWN","penDown"); 
        ("PENUP","penUp"); 
        ("PEN1","pen1"); 
        ("PEN2","pen2"); 
        ("PEN3","pen3"); 
        ("GOANDSLEEP","goAndSleep"); 
        ("LENGTH","length") 
        ] 
 
let grammersStrLst = 
   ["1: Program = PROGRAM CommandList"; 
    "2: CommandList = Command END"; 
    "3: Command = EPSILON"; 
    "4: Command = Command2 Command"; 
    "5: Command2 = RepeatCommand"; 
    "6: Command2 = PrimitiveCommand"; 
    "7: RepeatCommand = REPEAT NUM CommandList"; 
    "8: PrimitiveCommand = GO"; 
    "9: PrimitiveCommand = RIGHT"; 
    "10: PrimitiveCommand = LEFT"; 
    "11:PrimitiveCommand =PENRED"; 
    "12:PrimitiveCommand = PENBLACK"; 
    "13:PrimitiveCommand = PENBLUE"; 
    "14:PrimitiveCommand = PENUP"; 
    "15:PrimitiveCommand = PENDOWN" 
    "16:PrimitiveCommand = PEN1"; 
    "17:PrimitiveCommand = PEN2"; 
    "18:PrimitiveCommand = PEN3"; 
    "19: PrimitiveCommand = GOANDSLEEP NUM"; 
    "20: PrimitiveCommand = LENGTH NUM"; 
 
    ] 
 
let tp = new LL1TokenizeAndParse (tnR,grammersStrLst) 
 
/////////////Graphics//Pen//座標///向き//一歩の幅//oenがOnか 
type state = Graphics*Pen*(int*int)*int*int*bool 
     
let turnRight i = (i + 1) % 4 
let turnLeft  i = (i - 1) % 4 
 
let getNextPos i (x,y) length  = 
    if i = 0 then (x + length,y) 
    elif i = 1 then (x,y + length) 
    elif i = 2 then (x - length ,y) 
    else (x, y - length) 
 
let makeUpRepeatFunc (count:int) (f:state->state) = 
    let rec rf (c:int) (limit:int) (st:state) = 
        if limit = c then  st 
        else rf (c + 1) limit (f st) 
    rf 0 count  
 
let rec makeUpFunc (eb:embodyST)  = 
    match eb with 
    //0: Z = Program EOF 
    |Node(0,_,pro::_)      
        ->  makeUpFunc pro  
    //1  Program = PROGRAM CommandList 
    |Node(1,_,_:: cl :: _ )      
        -> makeUpFunc cl 
    //2  CommandList = Command END 
    |Node(2,_,cd ::_ )     
        -> makeUpFunc cd 
    //3  Command = ε 
    |Node(3,_,_ )     
        -> (fun s -> s) //引数をそのまま返す  idでもよい 
    //4  Command = Command2 Command 
    |Node(4,_,cd2::cd::_)     
        -> (makeUpFunc cd2) >> (makeUpFunc cd) 
    //5  Command2 = RepeatCommand 
    |Node(5,_,rc::_)      
        -> makeUpFunc  rc 
    //6  Command2 = PrimitiveCommand 
    |Node(6,_,pc::_)     
         -> makeUpFunc pc 
    //7  RepeatCommand = REPEAT NUM CommandList 
    |Node(7,_,_::Leaf(intStr)::cl::_)     
        ->  let repeatNum = System.Int32.Parse(intStr.Img) 
            makeUpRepeatFunc repeatNum (makeUpFunc cl)             
   //8  PrimitiveCommand = GO 
    |Node(8,_,_)      
        -> (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let (nextXPos,nextYPos) = getNextPos dir (x,y) length 
               if penUpOrDown = true then 
                    let oldPoint = new Point(x,y) 
                    let newPoint = new Point (nextXPos,nextYPos) 
                    gr.DrawLine(pen,oldPoint,newPoint) 
               (gr,pen, (nextXPos,nextYPos),dir,length,penUpOrDown) 
            ) 
    //9  PrimitiveCommand = RIGHT 
    |Node(9,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let nextDir = turnRight dir 
               (gr,pen, (x,y),nextDir,length,penUpOrDown) 
            )  
    //10 PrimitiveCommand = LEFT        
    |Node(10,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let nextDir = turnLeft dir 
               (gr,pen, (x,y),nextDir,length,penUpOrDown) 
            )  
    //11:PrimitiveCommand =PENRED 
    |Node(11,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Color <- Color.Red 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //12:PrimitiveCommand = PENBLACK 
    |Node(12,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Color <- Color.Black 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //13:PrimitiveCommand = PENBLUE 
    |Node(13,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Color <- Color.Blue 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //14:PrimitiveCommand = PENUP 
    |Node(14,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               (gr,pen, (x,y),dir,length,false) 
            )  
   //15:PrimitiveCommand = PENDOWN"  
    |Node(15,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               (gr,pen, (x,y),dir,length,true) 
            ) 
    //16:PrimitiveCommand = PEN1 
    |Node(16,_,_)    
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Width <- 1.0f 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
            )  
    //17:PrimitiveCommand = PEN2 
    |Node(17,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Width <- 2.0f 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
 
            ) 
    //18:PrimitiveCommand = PEN3 
    |Node(18,_,_)     
        ->(fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               pen.Width <- 3.0f 
               (gr,pen, (x,y),dir,length,penUpOrDown) 
 
            ) 
    //19: PrimitiveCommand = GOANDSLEEP NUM 
    |Node(19,_,_:: Leaf(intStr)::_)    
        -> let sleepTime = System.Int32.Parse(intStr.Img) 
           (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               let (nextXPos,nextYPos) = getNextPos dir (x,y) length 
               if penUpOrDown = true then 
                    let oldPoint = new Point(x,y) 
                    let newPoint = new Point (nextXPos,nextYPos) 
                    gr.DrawLine(pen,oldPoint,newPoint) 
               System.Threading.Thread.Sleep sleepTime  
               (gr,pen, (nextXPos,nextYPos),dir,length,penUpOrDown) 
            )         
     //20:  PrimitiveCommand = LENGTH NUM 
    |Node(20,_,_:: Leaf(intStr)::_)   
        -> let newLength = System.Int32.Parse(intStr.Img) 
           (fun ((gr,pen,(x,y),dir,length,penUpOrDown):state) -> 
               (gr,pen,(x,y),dir,newLength,penUpOrDown) 
            )         
    
    |_ -> failwith "RunTime error" 
 
 
let f2c x = x :> System.Windows.Forms.Control  
let canvas_pl= new Panel(BackColor = Color.White,Location = new Point(12, 12),Name = "canvas_pl",Size = new Size(577, 577),TabIndex = 0) 
let label5= new Label(AutoSize = true,Location = new Point(611, 21),Name = "label5",Size = new Size(33, 12),TabIndex = 31,Text = "ソース") 
let sourceSave_btn= new Button(Location = new Point(1045, 12),Name = "sourceSave_btn",Size = new Size(101, 23),TabIndex = 30,Text = "ソースのSave",UseVisualStyleBackColor = true) 
let sourceLoad_btn= new Button(Location = new Point(938, 12),Name = "sourceLoad_btn",Size = new Size(101, 23),TabIndex = 29,Text = "ソースのLoad",UseVisualStyleBackColor = true) 
let source_tb= new TextBox(Location = new Point(608, 41),Multiline = true,Name = "source_tb",ScrollBars = ScrollBars.Both,Size = new Size(538, 462),TabIndex = 28) 
let error_tb= new TextBox(Location = new Point(608, 553),Multiline = true,Name = "error_tb",ScrollBars = ScrollBars.Both,Size = new Size(524, 36),TabIndex = 29) 
let label6= new Label(AutoSize = true,Location = new Point(612, 528),Name = "label6",Size = new Size(32, 12),TabIndex = 32,Text = "エラー") 
let run_btn= new Button(Location = new Point(819, 509),Name = "run_btn",Size = new Size(75, 31),TabIndex = 33,Text = "Run",UseVisualStyleBackColor = true) 
let mainForm= new Form(AutoScaleDimensions = new SizeF(6.0f, 12.0f),AutoScaleMode = AutoScaleMode.Font,ClientSize = new Size(1158, 603),Name = "mainForm",Text = "LogoLikeLang") 
[ f2c run_btn; f2c label6; f2c error_tb; f2c source_tb; f2c label5; f2c canvas_pl; f2c sourceSave_btn; f2c sourceLoad_btn] |> List.iter(fun cnt -> mainForm.Controls.Add cnt) 
 
run_btn.Click.Add 
    (fun _ -> try 
                    error_tb.Text <- "" 
                    let sourceTextLst = source_tb.Text.Replace("\r\n", "\n").Split([|'\n'|]) |> List.ofArray 
                    let tree = tp.GetEBASTtree sourceTextLst 
                    let drawFunc = makeUpFunc tree  
                    use pen = new Pen(Color.Black,2.0f) 
                    use graphics = canvas_pl.CreateGraphics() 
                    graphics.Clear(canvas_pl.BackColor) 
                    /////state=//Graphics//Pen//座標///向き//一歩の幅//oenがOnか 
                    drawFunc (graphics,pen,(canvas_pl.Width /2,canvas_pl.Height/2),0,15,true) |> ignore 
              with 
                | ex -> error_tb.Text <- ex.Message  
    )  
 
sourceLoad_btn.Click.Add 
    (fun _ -> error_tb.Text <- ""  
              try  
                let ofd = new OpenFileDialog(Filter = "srcファイル(*.src)|*.src|すべてのファイル(*.*)|*.*")  
                if(ofd.ShowDialog() = DialogResult.OK) then  
                    use sr = new System.IO.StreamReader(ofd.FileName)  
                    source_tb.Text <- sr.ReadToEnd()  
              with  
                | ex -> error_tb.Text <- ex.Message  
    )  
 
sourceSave_btn.Click.Add  
    (fun _ -> error_tb.Text <- ""   
              try  
                let sfd = new SaveFileDialog(Filter = "srcファイル(*.src)|*.src|すべてのファイル(*.*)|*.*",  
                                              RestoreDirectory = true)  
                if (sfd.ShowDialog() = DialogResult.OK) then  
                    use sw = new System.IO.StreamWriter(sfd.FileName)  
                    sw.Write(source_tb.Text)  
              with  
                | ex -> error_tb.Text <- ex.Message  
                  
    )  
 
[<STAThread()>]   
do Application.Run(mainForm) 
スポンサーサイト

テーマ : プログラミング
ジャンル : コンピュータ

コメントの投稿

非公開コメント

プロフィール

T GYOUTEN

Author:T GYOUTEN
F#と英単語とフリーソフトと読書に興味があります。
ホームページでフリーソフトも公開しています。どぞ御贔屓に。

最新記事
最新コメント
最新トラックバック
月別アーカイブ
カテゴリ
フリーエリア
フリーエリア
blogram投票ボタン
検索フォーム
RSSリンクの表示
リンク
ブロとも申請フォーム

この人とブロともになる

QRコード
QRコード
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。