スポンサーサイト

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

F#で入門 コンパイラ、インタプリタ編 Whitespace(13)

 さて今までの実装ではWhitespaceのコードを書くには「目に見えない形」で書くか、「s,t,nを用いた形」で書くしかなかったのですが、今回は"push 4 ;dup;...."というような、頭にやさしい形でコードを書けるようにしたいと思います。 
この表現方法を今後の説明上「頭易表現」と名付けておきます。(糖衣表現の打ち間違いではありません。) 
 
まず頭易表現の形を決めたいとおもいます。 
命令文毎はcみたいに「;」で区切ることにします。;に続けて改行も可にすることにします。 
 
Command型との対応は次の様にすることにします。 
 
push 1        ⇔ SPush(1) 
dup           ⇔ SDup 
copy 2        ⇔ SCopy(2) 
swap          ⇔ SSwap 
discard       ⇔ SDiscard 
slide 3       ⇔ SSlide(3) 
add           ⇔ TSAdd 
sub           ⇔ TSSub 
mul           ⇔ TSMul 
div           ⇔ TSDiv 
mod           ⇔ TSMod 
store         ⇔ TTStore 
retrieve      ⇔ TTRetrieve 
mark sn       ⇔ NMark("sn") 
jump sn       ⇔ NJump("sn") 
jumpZero sn   ⇔ NJumpZero("sn") 
jumpNega sn   ⇔ NJumpNega("sn") 
callSub sn    ⇔ NCallSub("sn") 
endSub        ⇔ NEndSub 
charOut       ⇔ TNCharOut 
intOut        ⇔ TNIntOut 
charRead      ⇔ TNCharRead 
intRead       ⇔ TNIntRead 
exit          ⇔ FExit 
 
例えばコードは次のようになります。 
 
push 0;intRead; 
push1;intRead; 
push0;retrieve; 
push1;retrieve; 
add; 
intOut; 
exit; 
 
今回は「頭易表現」からCommand[]型への変換部分を実装したいと思います。 
これは「s,t,n表現」からCommand[]型への変換とよく似ているので使い回しできる部分はすでに実装してあるものを利用します。 
 
大きな流れとしては次のように行います。 
 
"push 2;dup;push -2"--(1)-->["push 2";"dup";"push -2"]--(2)-->[SPush(2);Dup;Spush(-2)] 
 
では実装していきますが、なるだけs,t,n形式からの変換で作った関数群を利用する方針でいきます。 
 
s,t,n形式からの変換では、 
 
let createFromInt (partStr:string) (rg:Regex) (str:string) (creInt:int->Command) = 
         let wholeMatch = rg.Match(str) 
         let partMatch = wholeMatch.Groups.[partStr] 
         if partMatch.Value.Length > 0 then 
            Some(creInt(wToNum partMatch.Value),wholeMatch.Length) 
         else 
            None 
 
let createFromNothing (rg:Regex) (str:string) (cre:unit->Command) = 
        let wholeMatch = rg.Match(str) 
.......... 
 
という関数群と、 
 
let ComKindLst = 
     [(new Regex("^ss(?<num_part>(s|t)(s|t)+)n"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str wToNum (fun num -> SPush(num)))); 
      ( new Regex("^sns"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDup))); 
........ 
というリストを利用して実現していましたが、これを再利用するには、createFromInt関数内のwToNum関数("ss..."を数値変換する)が使えないので、(今回は"4"を数値の4等に変換する必要がある)この文字列から数値への変換関数を引数にしておきます。 
つまり上の部分を次のように修正しておきます。 
 
let createFromInt (partStr:string) (rg:Regex) (str:string) (toNum:string->int) (creInt:int->Command)  = 
         let wholeMatch = rg.Match(str) 
         let partMatch = wholeMatch.Groups.[partStr] 
         if partMatch.Value.Length > 0 then 
            Some(creInt(toNum partMatch.Value),wholeMatch.Length) //wToNumが引数のtoNumに変更 
         else 
            None 
 
またリスト部分も次のように修正しておきます。 
 
let ComKindLst = 
     [(new Regex("^ss(?<num_part>(s|t)(s|t)+)n"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str wToNum (fun num -> SPush(num)))) 
                                     //wTonumが引数に加わった 
      ( new Regex("^sns"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDup))); 
 
では準備ができたので関数等を定義していきます。 
 
正規表現での切り出し対応タプルリストを定義します。 
 
let AnnotherComKindLst = 
     [(new Regex("^\s*(P|p)ush\s*(?<num_part>(\+|\-)?(\d)+)\s*"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str  (System.Int32.Parse) (fun num -> SPush(num)))); 
      ( new Regex("^\s*(D|d)up\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDup))); 
      ( new Regex("^\s(C|c)opy\s*(?<num_part>(\+|\-)?(\d)+)\s*"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str  (System.Int32.Parse) (fun num -> SCopy(num)))); 
      ( new Regex("^\s(S|s)wap\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SSwap))); 
      ( new Regex("^\s*(D|d)iscard\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDiscard))); 
      ( new Regex("^\s*(S|s)lide\s*(?<num_part>(\+|\-)?(\d)+)\s*"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str (System.Int32.Parse) (fun num -> SSlide(num)))); 
      ( new Regex("^\s*(A|a)dd\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSAdd))); 
      ( new Regex("^\s*(S|s)ub\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSSub))); 
      ( new Regex("^\s*(M|m)ul\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSMul))); 
      ( new Regex("^\s*(D|d)iv\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSDiv))); 
      ( new Regex("^\s*(M|m)od\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSMod))); 
      ( new Regex("^\s*(S|s)tore\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TTStore))); 
      ( new Regex("^\s*(R|r)etrieve\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TTRetrieve))); 
      ( new Regex("^\s*(M|m)ark\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NMark(str)))); 
      ( new Regex("^\s*(J|j)ump\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJump(str)))); 
      ( new Regex("^\s*(J|j)ump(Z|z)ero\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJumpZero(str)))); 
      ( new Regex("^\s*(J|j)ump(N|n)ega\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJumpNega(str)))); 
      ( new Regex("^\s*(C|c)all(S|s)ub\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NCallSub(str)))); 
      ( new Regex("^\s*(E|e)nd(S|s)ub\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> NEndSub))); 
      ( new Regex("^\s*(C|c)har(O|o)ut\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNCharOut))); 
      ( new Regex("^\s*(I|i)nt(O|o)ut\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNIntOut))); 
      ( new Regex("^\s*(C|c)har(R|r)ead\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNCharRead))); 
      ( new Regex("^\s*(I|i)nt(R|r)ead\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNIntRead))); 
      ( new Regex("^\s*(E|e)xit\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> FExit))); 
     ] 
      
 
補助関数を定義します。 
 
(次のtryApplyはすでに実装済みの関数です。) 
>let rec tryApply (cmdLst:list<CKL>) (str:string) = 
    match cmdLst with 
    | [] -> None 
    | (rg,f)::tl -> let res = f rg str 
                    if res.IsSome then 
                        res 
                    else 
                        tryApply tl str;; 
 
val tryApply : CKL list -> string -> (Command * int) option 
 
次は新たに実装する関数です。 
> let rec AnotherMakeCASub (cmdLst2:list<CKL>) (strLst:list<string>) (index:int) (res:list<Command>) = 
    match strLst with 
    |[] -> res 
    |hd :: tl -> let matched =tryApply AnnotherComKindLst hd 
                 if matched = None then 
                    failwith (sprintf "%d要素目の部分でマッチするものが見つかりません" index) 
                 else 
                    let (com,_) = matched.Value 
                    AnotherMakeCASub cmdLst2 tl (index+1)  (com::res);; 
 
val AnotherMakeCASub : 
  CKL list -> string list -> int -> Command list -> Command list 
 
テストしてみます。 
> AnotherMakeCASub AnnotherComKindLst [" push 3";"dup";" Push -3"] 0 [];; 
val it : Command list = [SPush -3; SDup; SPush 3] 
 
次も新たに実装する関数です。 
 
> let AnotherMakeCArr (cmdLst2:list<CKL>) (src:string) = 
    let splitedPartsArray = src.Trim().Split ([|";";"\n"|],System.StringSplitOptions.RemoveEmptyEntries) 
    AnotherMakeCASub cmdLst2 (List.ofArray splitedPartsArray) 0 [] 
    |> List.rev 
    |>Array.ofList;; 
 
val AnotherMakeCArr : CKL list -> string -> Command [] 
 
テストしてみます。 
> AnotherMakeCArr AnnotherComKindLst  " push 3;dup;slide 3; Push -3;\n";; 
val it : Command [] = [|SPush 3; SDup; SSlide 3; SPush -3|] 
 
> AnotherMakeCArr AnnotherComKindLst  "dup;slide 3;mark stn; Push -3;";; 
val it : Command [] = [|SDup; SSlide 3; NMark "stn"; SPush -3|] 
 
では、頭易表現を打ち込むテキストボックスとそれを変換するボタンをウィンドウに追加して、実行画面は次のようになります。(2数を入力して和を出力するプログラムを実行したところです。) 
 472-1.jpg

ここまでの全コードは次の通りです。 
 open System   
open System.Windows.Forms   
open System.Drawing   
open System.Text.RegularExpressions 
 
////////////////入出力用関数ホルダ//////////////// 
let mutable forInputFunc :(unit->string)    = (fun () -> "") 
let mutable forOutputFunc:(string->unit) = (fun _ -> ()) 
let mutable forStateDispFunc:(string->unit) = (fun _ -> ()) 
 
////////////////正規表現用の補助関数/////////////// 
 
let myReplace (regStr:string) (repStr:string) (oriSrcStr:string)= 
    (new Regex(regStr)).Replace(oriSrcStr,repStr) 
 
///////////////視覚化関数////////////////////////// 
 
let visualize (src:string) = 
    src 
    |> myReplace "[^\s]" "" 
    |> myReplace " " "s" 
    |> myReplace "\t" "t" 
    |> myReplace "\n" "n" 
 
///////////////無視覚化関数////////////////////////// 
 
let unvisualize (stnSrc:string) = 
    stnSrc 
    |> myReplace"[\s]" "" 
    |> myReplace "s" " " 
    |> myReplace "t" "\t" 
    |> myReplace "n" "\n" 
 
////////////s,t,nによる数値表現をintに変換する関数(最後のnは除かれた状態から) 
 
let wToNum (str:string) = 
        let strbiNum = 
           str.Substring(1) 
            |> myReplace "s" "0" 
            |> myReplace "t" "1" 
        let absPart10 = System.Convert.ToInt32 (strbiNum,2) 
        if str.Substring(0,1) = "s" then absPart10 
        elif str.Substring(0,1) = "t" then (-1)*absPart10 
        else failwith "数値表現エラー" 
 
///////////上の逆関数(最後のnは付ける) 
 
let numToStn (num:int) = 
    let absPart = abs num 
    let stNum = 
        System.Convert.ToString(absPart,2) 
        |> myReplace "0" "s" 
        |> myReplace "1" "t" 
    if num >= 0 then  
        "s" + stNum + "n" 
    else  
        "t" + stNum + "n"  
 
/////////////プログラムの中核をなすコマンド型/////// 
 
type Command = 
    |SPush of int 
    |SDup 
    |SCopy of int 
    |SSwap 
    |SDiscard 
    |SSlide of int 
    |TSAdd 
    |TSSub 
    |TSMul 
    |TSDiv 
    |TSMod 
    |TTStore 
    |TTRetrieve 
    |NMark of string 
    |NJump of string 
    |NJumpZero of string 
    |NJumpNega of string 
    |NCallSub of string 
    |NEndSub 
    |TNCharOut 
    |TNIntOut 
    |TNCharRead 
    |TNIntRead 
    |FExit 
 
/////////////正規表現で切り出す補助関数群///////// 
 
let createFromInt (partStr:string) (rg:Regex) (str:string) (toNum:string->int) (creInt:int->Command)  = 
         let wholeMatch = rg.Match(str) 
         let partMatch = wholeMatch.Groups.[partStr] 
         if partMatch.Value.Length > 0 then 
            Some(creInt(toNum partMatch.Value),wholeMatch.Length) 
         else 
            None 
 
let createFromNothing (rg:Regex) (str:string) (cre:unit->Command) = 
        let wholeMatch = rg.Match(str) 
        if wholeMatch.Success = true then 
               Some(cre(),wholeMatch.Length) 
        else None 
 
let createFromString (partStr:string) (rg:Regex) (str:string) (creStr:string->Command) = 
         let wholeMatch = rg.Match(str) 
         let partMatch = wholeMatch.Groups.[partStr] 
         if partMatch.Value.Length > 0 then 
            Some(creStr( partMatch.Value),wholeMatch.Length) 
         else 
            None 
 
 
/////////////正規表現での切り出し対応タプルリスト1("sstnssttnn" からの変換用)// 
 
let ComKindLst = 
     [(new Regex("^ss(?<num_part>(s|t)(s|t)+)n"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str wToNum (fun num -> SPush(num)))); 
      ( new Regex("^sns"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDup))); 
      ( new Regex("^sts(?<num_part>(s|t)(s|t)+)n"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str wToNum (fun num -> SCopy(num)))); 
      ( new Regex("^snt"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SSwap))); 
      ( new Regex("^snn"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDiscard))); 
      ( new Regex("^stn(?<num_part>(s|t)(s|t)+)n"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str wToNum (fun num -> SSlide(num)))); 
      ( new Regex("^tsss"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSAdd))); 
      ( new Regex("^tsst"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSSub))); 
      ( new Regex("^tssn"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSMul))); 
      ( new Regex("^tsts"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSDiv))); 
      ( new Regex("^tstt"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSMod))); 
      ( new Regex("^tts"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TTStore))); 
      ( new Regex("^ttt"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TTRetrieve))); 
      ( new Regex("^nss(?<str_part>(s|t)+n)"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NMark(str)))); 
      ( new Regex("^nsn(?<str_part>(s|t)+n)"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJump(str)))); 
      ( new Regex("^nts(?<str_part>(s|t)+n)"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJumpZero(str)))); 
      ( new Regex("^ntt(?<str_part>(s|t)+n)"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJumpNega(str)))); 
      ( new Regex("^nst(?<str_part>(s|t)+n)"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NCallSub(str)))); 
      ( new Regex("^ntn"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> NEndSub))); 
      ( new Regex("^tnss"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNCharOut))); 
      ( new Regex("^tnst"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNIntOut))); 
      ( new Regex("^tnts"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNCharRead))); 
      ( new Regex("^tntt"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNIntRead))); 
      ( new Regex("^nnn"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> FExit))); 
     ] 
 
/////////////正規表現での切り出し対応タプルリスト2("push 3;dup\n;" からの変換用)// 
 
let AnnotherComKindLst = 
     [(new Regex("^\s*(P|p)ush\s*(?<num_part>(\+|\-)?(\d)+)\s*"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str  (System.Int32.Parse) (fun num -> SPush(num)))); 
      ( new Regex("^\s*(D|d)up\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDup))); 
      ( new Regex("^\s(C|c)opy\s*(?<num_part>(\+|\-)?(\d)+)\s*"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str  (System.Int32.Parse) (fun num -> SCopy(num)))); 
      ( new Regex("^\s(S|s)wap\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SSwap))); 
      ( new Regex("^\s*(D|d)iscard\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> SDiscard))); 
      ( new Regex("^\s*(S|s)lide\s*(?<num_part>(\+|\-)?(\d)+)\s*"), 
        (fun (rg:Regex) str -> createFromInt "num_part" rg str (System.Int32.Parse) (fun num -> SSlide(num)))); 
      ( new Regex("^\s*(A|a)dd\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSAdd))); 
      ( new Regex("^\s*(S|s)ub\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSSub))); 
      ( new Regex("^\s*(M|m)ul\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSMul))); 
      ( new Regex("^\s*(D|d)iv\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSDiv))); 
      ( new Regex("^\s*(M|m)od\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TSMod))); 
      ( new Regex("^\s*(S|s)tore\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TTStore))); 
      ( new Regex("^\s*(R|r)etrieve\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TTRetrieve))); 
      ( new Regex("^\s*(M|m)ark\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NMark(str)))); 
      ( new Regex("^\s*(J|j)ump\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJump(str)))); 
      ( new Regex("^\s*(J|j)ump(Z|z)ero\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJumpZero(str)))); 
      ( new Regex("^\s*(J|j)ump(N|n)ega\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NJumpNega(str)))); 
      ( new Regex("^\s*(C|c)all(S|s)ub\s*(?<str_part>(s|t)+n)\s*"), 
        (fun (rg:Regex) str -> createFromString "str_part" rg str (fun str -> NCallSub(str)))); 
      ( new Regex("^\s*(E|e)nd(S|s)ub\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> NEndSub))); 
      ( new Regex("^\s*(C|c)har(O|o)ut\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNCharOut))); 
      ( new Regex("^\s*(I|i)nt(O|o)ut\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNIntOut))); 
      ( new Regex("^\s*(C|c)har(R|r)ead\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNCharRead))); 
      ( new Regex("^\s*(I|i)nt(R|r)ead\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> TNIntRead))); 
      ( new Regex("^\s*(E|e)xit\s*"), 
        (fun (rg:Regex) str -> createFromNothing rg str (fun () -> FExit))); 
     ] 
////////上のComKindLstの要素の型の別名///////////////////////// 
 
type CKL = System.Text.RegularExpressions.Regex * 
                         (System.Text.RegularExpressions.Regex -> string -> (Command * int) option) 
 
///////下のmakeCLSubの補助関数///////////////////////////////// 
 
let rec tryApply (cmdLst:list<CKL>) (str:string) = 
    match cmdLst with 
    | [] -> None 
    | (rg,f)::tl -> let res = f rg str 
                    if res.IsSome then 
                        res 
                    else 
                        tryApply tl str 
///////下のmakeCArrayの補助関数///////////////////////////////// 
 
let rec makeCASub (cmdLst:list<CKL>) (str:string) (index:int) (res:list<Command>) = 
    if str.Length = 0 then  
        res 
    else 
        let matchRes = tryApply cmdLst str 
        if matchRes = None then 
            failwith (sprintf "%d文字目からの部分でマッチするものが見つかりません" index) 
        else 
            let (com,len) = matchRes.Value 
            makeCASub cmdLst (str.Substring(len)) (index + len) (com::res)  
 
//////"stss.."等のstringから [|SDup; SPush 5...|]のような配列を作る関数//////////////////////                  
 
let makeCArray (cmdLst:list<CKL>) (src:string) = 
    let bleachedSrc = myReplace "\s" ""  src 
    makeCASub cmdLst bleachedSrc 0 [] 
    |> List.rev 
    |> Array.ofList 
 
/////////上のmakeCASubの[" push 3";"dup";" Push -3"]等からの変換版/////////////////////// 
 
let rec AnotherMakeCASub (cmdLst2:list<CKL>) (strLst:list<string>) (index:int) (res:list<Command>) = 
    match strLst with 
    |[] -> res 
    |hd :: tl -> let matched =tryApply AnnotherComKindLst hd 
                 if matched = None then 
                    failwith (sprintf "%d要素目の部分でマッチするものが見つかりません" index) 
                 else 
                    let (com,_) = matched.Value 
                    AnotherMakeCASub cmdLst2 tl (index+1)  (com::res) 
 
 
///////////上の上のmakeCArrayの" push 3;dup; Push -3;"等からの変換版 
 
let AnotherMakeCArr (cmdLst2:list<CKL>) (src:string) = 
    let splitedPartsArray = src.Trim().Split ([|";";"\n"|],System.StringSplitOptions.RemoveEmptyEntries) 
    AnotherMakeCASub cmdLst2 (List.ofArray splitedPartsArray) 0 [] 
    |> List.rev 
    |>Array.ofList 
 
/////[|SDup; NMark "ttn";..|]のような配列から、map [("ttn",1;..]というような対応表を作る関数/// 
 
let makeLabelMap (cmdArr:Command[]) = 
    let rec makeLabelMapSub cmdLst index res = 
        match cmdLst with 
        | [] -> res 
        |NMark(label)::tl ->makeLabelMapSub tl (index+1) (Map.add label index res) 
        |hd::tl           ->makeLabelMapSub tl (index+1)  res 
    makeLabelMapSub (List.ofArray cmdArr) 0 (Map.empty)     
 
////////ラベルからプログラムカウンタを返す関数////////////////////////// 
////////引数のプログラムカウンタはエラー表示用////////////////////////// 
 
let getPC (labelMap:Map<string,int>) (pc:int) (label:string) = 
    let findRes = Map.tryFind label labelMap 
    if findRes.IsSome then 
        findRes.Value 
    else 
        failwith (sprintf "index:%d 対応するラベルがありません。" pc) 
 
///////状態を表すタプルの別名//////////////////////////////////// 
 
type WState = int*list<int>*Map<int,int>*list<int> 
 
///////それぞれの命令に対応する関数群//////////////////////////// 
 
let do_SDup ((pc,stcLst,heapMap,rIndexLst):WState) = 
    if List.length stcLst = 0 then failwith(sprintf "index:%d スタックが空でDupできません。" pc) 
    (pc+1,(List.head stcLst)::stcLst,heapMap,rIndexLst) 
 
let do_SSwap((pc,stcLst,heapMap,rIndexLst):WState) = 
    match stcLst with 
    |h1::h2::tl -> (pc+1,h2::h1::tl,heapMap,rIndexLst) 
    | _-> failwith(sprintf "index:%d スタックの要素の個数が1以下です" pc) 
   
let do_SDiscard ((pc,stcLst,heapMap,rIndexLst):WState) = 
    if List.length stcLst = 0 then failwith(sprintf "index:%d スタックが空でDiscardできません。" pc) 
    (pc+1,(List.tail stcLst),heapMap,rIndexLst) 
 
let do_SPush (num:int) ((pc,stcLst,heapMap,rIndexLst):WState) = 
    (pc+1,num::stcLst,heapMap,rIndexLst) 
 
let do_SCopy (n:int) ((pc,stcLst,heapMap,rIndexLst):WState) =     
    if (List.length stcLst) <= n then  failwith(sprintf "index:%d スタックの要素数がたりずにSCopyできません。" pc) 
    let tempArr = Array.ofList stcLst 
    (pc+1,(tempArr.[n])::stcLst,heapMap,rIndexLst) 
     
let do_SSlide (n:int) ((pc,stcLst,heapMap,rIndexLst):WState) = 
    if (List.length stcLst) <= n then  failwith(sprintf "index:%d スタックの要素数がたりずにSSlideできません。" pc) 
    let tempArr = Array.ofList stcLst 
    let slicedArr = tempArr.[(n + 1) ..] 
    let newStcLst = (List.head stcLst)::(List.ofArray slicedArr) 
    (pc+1,newStcLst,heapMap,rIndexLst) 
 
let do_OpSub (op:int->int->int) ((pc,stcLst,heapMap,rIndexLst):WState) = 
    match stcLst with 
    |v1::v2::rem -> (pc+1,(op v2 v1)::rem,heapMap,rIndexLst) 
    | _     ->failwith(sprintf "index:%d スタックの要素数がたりずに演算できません。" pc) 
     
let do_TSAdd (t:WState) =  
    do_OpSub (+) t   
 
let do_TSSub (t:WState) =  
    do_OpSub (-) t   
 
let do_TSMul (t:WState) =  
    do_OpSub (*) t   
 
let do_TSDiv (t:WState) =  
    do_OpSub (/) t   
 
let do_TSMod (t:WState) =  
    do_OpSub (%) t   
 
let do_TTStore ((pc,stcLst,heapMap,rIndexLst):WState) = 
    match stcLst with 
    |v1::v2::rem -> (pc+1,rem,Map.add v2 v1 heapMap,rIndexLst) 
    |_    ->failwith(sprintf "index:%d スタックの要素数がたりずにStoreできません。" pc) 
 
let do_TTRetrieve ((pc,stcLst,heapMap,rIndexLst):WState) = 
    match stcLst with 
    |v::rem -> let retreivedVal = Map.tryFind v heapMap 
               if retreivedVal.IsSome then 
                    (pc+1,retreivedVal.Value::rem,heapMap,rIndexLst) 
               else failwith(sprintf "index:%d 指定されたアドレスにデータがないためRetrieveできません。" pc) 
    |_    ->failwith(sprintf "index:%d スタックの要素数がたりずにRetrieveできません。" pc) 
 
let do_NMark (label:string) ((pc,stcLst,heapMap,rIndexLst):WState) = 
    (pc+1,stcLst,heapMap,rIndexLst) 
 
let do_NJump (labelMap:Map<string,int>) (label:string) ((pc,stcLst,heapMap,rIndexLst):WState) = 
    let next_pc = getPC labelMap pc label 
    (next_pc,stcLst,heapMap,rIndexLst) 
 
let do_NJumpCondSub (f:int->bool) (labelMap:Map<string,int>) (label:string)  
                    ((pc,stcLst,heapMap,rIndexLst):WState)   = 
    match stcLst with 
    |v::rem -> if f v then  
                  let next_pc = getPC labelMap pc label 
                  (next_pc,rem,heapMap,rIndexLst) 
               else 
                  (pc+1,rem,heapMap,rIndexLst) 
    |_      -> failwith(sprintf "index:%d スタックが空なので条件ジャンプできません。" pc)   
 
let do_NJumpZero = do_NJumpCondSub (fun i -> i = 0) 
 
let do_NJumpNega = do_NJumpCondSub (fun i -> i < 0) 
 
let do_NCallSub (labelMap:Map<string,int>) (label:string) ((pc,stcLst,heapMap,rIndexLst):WState) = 
    let next_pc = getPC labelMap pc label 
    (next_pc,stcLst,heapMap,(pc+1)::rIndexLst) 
 
let do_NEndSub ((pc,stcLst,heapMap,rIndexLst):WState) = 
    match rIndexLst with 
    |r_pc::rem -> (r_pc,stcLst,heapMap,rem) 
    |_ ->failwith(sprintf "index:%d 戻り先スタックが空なので戻れません。" pc) 
 
let do_TNCharOut ((pc,stcLst,heapMap,rIndexLst):WState) = 
    match stcLst with 
    |v::rem -> forOutputFunc ((char v).ToString()) 
               (pc+1,rem,heapMap,rIndexLst)  
    |_      -> failwith(sprintf "index:%d スタックが空なので表示できません。" pc)   
                 
let do_TNIntOut ((pc,stcLst,heapMap,rIndexLst):WState) = 
    match stcLst with 
    |v::rem -> forOutputFunc (v.ToString()) 
               (pc+1,rem,heapMap,rIndexLst)  
    |_      -> failwith(sprintf "index:%d スタックが空なので表示できません。" pc)   
 
let do_TNCharRead ((pc,stcLst,heapMap,rIndexLst):WState) = 
    let inputVal = System.Char.Parse (forInputFunc()) 
    match stcLst with 
    |v::rem ->(pc+1,rem,(Map.add v (int inputVal) heapMap),rIndexLst)  
    |_      -> failwith(sprintf "index:%d スタックが空なので書き込みできません。" pc)   
 
let do_TNIntRead ((pc,stcLst,heapMap,rIndexLst):WState) = 
    let inputVal = System.Int32.Parse(forInputFunc()) 
    match stcLst with 
    |v::rem ->(pc+1,rem,(Map.add v inputVal heapMap),rIndexLst)  
    |_      -> failwith(sprintf "index:%d スタックが空なので書き込みできません。" pc)   
 
 
let do_FExit ((pc,stcLst,heapMap,rIndexLst):WState) =     
    () 
 
////////命令を解釈しながら状態を変化させていく中心の関数//////////////// 
 
let rec processCmd (cmds :Command[]) (startWState:WState) = 
    let labelMap = makeLabelMap cmds //ジャンプ命令等で使用する  
    forStateDispFunc (sprintf "ラベル::pc対応Map %A\n" labelMap) //デバック用 
    let rec processCmdSub  ((pc,stcLst,heapMap,rIndexLst) as t:WState) = 
        if pc < 0 || pc >= Array.length cmds then failwith (sprintf "index:%d pcが領域外です" pc) 
        forStateDispFunc (sprintf "%A\n" t)  //デバック用 
        let cur_cmd = cmds.[pc] //現在のプログラムカウンタにある命令をとってくる 
        forStateDispFunc (sprintf "%A\n" cur_cmd) //デバック用 
        match cur_cmd with 
        |SPush(num)   -> do_SPush num t  |> processCmdSub 
        |SDup         -> do_SDup t       |> processCmdSub 
        |SCopy (n)    -> do_SCopy n t    |> processCmdSub 
        |SSwap        -> do_SSwap t      |> processCmdSub 
        |SDiscard     -> do_SDiscard t   |> processCmdSub 
        |SSlide (n)   -> do_SSlide n t   |> processCmdSub 
        |TSAdd        -> do_TSAdd t      |> processCmdSub 
        |TSSub        -> do_TSSub t      |> processCmdSub 
        |TSMul        -> do_TSMul t      |> processCmdSub 
        |TSDiv        -> do_TSDiv t      |> processCmdSub 
        |TSMod        -> do_TSMod t      |> processCmdSub 
        |TTStore      -> do_TTStore t    |> processCmdSub 
        |TTRetrieve   -> do_TTRetrieve t |> processCmdSub 
        |NMark(lb)    -> do_NMark lb t   |> processCmdSub 
        |NJump(lb)    -> do_NJump labelMap lb t     |> processCmdSub 
        |NJumpZero(lb)-> do_NJumpZero labelMap lb t |> processCmdSub 
        |NJumpNega(lb)-> do_NJumpNega labelMap lb t |> processCmdSub 
        |NCallSub(lb) -> do_NCallSub labelMap lb t  |> processCmdSub 
        |NEndSub      -> do_NEndSub t               |> processCmdSub 
        |TNCharOut    -> do_TNCharOut t  |> processCmdSub 
        |TNIntOut     -> do_TNIntOut t   |> processCmdSub 
        |TNCharRead   -> do_TNCharRead t |> processCmdSub 
        |TNIntRead    -> do_TNIntRead t  |> processCmdSub 
        |FExit        -> do_FExit t 
    processCmdSub startWState 
 
//Command型の値を引数として、s,t,nでの表現文字列を返す関数command2StnSub 
 
let command2StnSub (cmd:Command) = 
    match cmd with 
    |SPush (num)     -> "ss" + (numToStn num) 
    |SDup            -> "sns"         
    |SCopy (num)     -> "sts" + (numToStn num) 
    |SSwap           -> "snt"   
    |SDiscard        -> "snn" 
    |SSlide (num)    -> "stn" + (numToStn num) 
    |TSAdd           -> "tsss" 
    |TSSub           -> "tsst" 
    |TSMul           -> "tssn" 
    |TSDiv           -> "tsts" 
    |TSMod           -> "tstt"  
    |TTStore         -> "tts"   
    |TTRetrieve      -> "ttt" 
    |NMark (label)   -> "nss" + label 
    |NJump (label)   -> "nsn" + label 
    |NJumpZero(label)-> "nts" + label 
    |NJumpNega(label)-> "ntt" + label 
    |NCallSub(label) -> "nst" + label 
    |NEndSub         -> "ntn" 
    |TNCharOut       -> "tnss" 
    |TNIntOut        -> "tnst" 
    |TNCharRead      -> "tnts" 
    |TNIntRead       -> "tntt"  
    |FExit           -> "nnn" 
 
let command2Stn (comArr:Command[]) = 
    let stnArr = Array.map (fun cmd -> command2StnSub cmd) comArr 
    let sb = new System.Text.StringBuilder() 
    for stnStr in stnArr do 
        (sb.Append (stnStr)).Append("\n") |> ignore 
    sb.ToString() 
 
//メインフォーム関連 
let mainForm = new Form(Width = 1015, Height = 654, Text = "Whitespace studio") 
 
let wSource_tb = new RichTextBox(Width = 155,Height = 97,Location =new Point(32,65), Multiline = true) 
let stnSource_tb = new RichTextBox(Width = 155,Height = 105,Location =new Point(32,223), Multiline = true)  
let output_tb = new RichTextBox(Width = 155,Height = 105,Location =new Point(32,404), Multiline = true) 
let editor_tb =  new RichTextBox(Width =426,Height = 202,Location =new Point(555,37), Multiline = true) 
let error_tb =  new RichTextBox(Width = 949,Height = 53,Location =new Point(32,539), Multiline = true) 
 
let log_tb =  new RichTextBox(Width = 487,Height = 229,Location =new Point(494,280), Multiline = true) 
 
let command_lb = new ListBox(Width = 172,Height = 472,Location =new Point(297,37), HorizontalScrollbar = true,ScrollAlwaysVisible = true) 
 
let wsrc_load_btn=new Button (Width = 67,Height = 23,Location =new Point(32,33),Text = "Load") 
let wsrc_save_btn=new Button (Width = 67,Height = 23,Location =new Point(120,33),Text = "Save") 
let ws_cls_btn  = new Button (Width = 54,Height = 23,Location =new Point(32,174),Text = "Clear") 
let w2stn_btn   = new Button (Width = 43,Height = 23,Location =new Point(92,174),Text = "↓") 
let stn2w_btn   = new Button (Width = 43,Height = 23,Location =new Point(144,174),Text = "↑") 
let stn2c_btn   = new Button (Width = 43,Height = 23,Location =new Point(216,238),Text = "→") 
let c2stn_btn   = new Button (Width = 43,Height = 23,Location =new Point(216,280),Text = "←") 
let STN_cls_btn = new Button (Width = 54,Height = 23,Location =new Point(32,340),Text = "Clear") 
let run_btn     = new Button (Width = 75,Height = 61,Location =new Point(205,423),Text = "←Run-") 
let e2c_btn     = new Button (Width = 55,Height = 47,Location =new Point(484,94),Text = "←") 
 
[wSource_tb;stnSource_tb;output_tb;error_tb;editor_tb;log_tb] 
|> List.iter(fun tb -> mainForm.Controls.Add tb) 
 
[command_lb] 
|> List.iter(fun tb -> mainForm.Controls.Add tb) 
 
[wsrc_load_btn;wsrc_save_btn;ws_cls_btn;w2stn_btn;stn2w_btn;stn2c_btn;c2stn_btn;STN_cls_btn;run_btn; 
 e2c_btn] 
|> List.iter(fun btn -> mainForm.Controls.Add btn) 
 
[((37,16),(55,12),"WSouce");((37,208),(70,12),"STNSource");((37,381),(45,12),"Output") 
 ((37,520),(35,12),"Error");((295,16),(65,12),"Commands");((553,16),(35,12),"Editor"); 
 ((496,267),(23,12),"Log")] 
 |>List.iter(fun ((lx,ly),(sx,sy),str) -> mainForm.Controls.Add (new Label(Width = sx,Height = sy,Location = new Point(lx,ly),Text = str))) 
 
//入力用サブフォーム関連 
let inputForm = new Form(Width = 300, Height = 150, Text = "input Form") 
let subInput_tb =  new TextBox(Width = 155,Height = 97,Location =new Point(5,5)) 
let subInput_btn = new Button (Width = 75,Height = 23,Location =new Point(5,50),Text = "Submit") 
 
inputForm.Controls.Add subInput_tb 
inputForm.Controls.Add subInput_btn 
 
////////////////現在登録されているCommand[]/////////////////////////// 
let mutable (resistered_ComArr:Command[]) = [||] 
 
///ログ用の文字列生成用StringBuilder 
let sbForLog = new System.Text.StringBuilder() 
 
 
//テキストボックスクリア用の補助関数 
let clear_error_tb () = error_tb.Clear() 
let clear_log_lb () = log_tb.Clear() 
let clear_output_tb () = output_tb.Clear() 
 
  
///表示,入力関数の指定 
forStateDispFunc <-  (fun str ->  sbForLog.Append (str) |> ignore )   
 
forInputFunc     <- (fun () ->subInput_tb.Text  <- "" 
                              inputForm.ShowDialog() |> ignore 
                              subInput_tb.Text) 
                               
forOutputFunc <- (fun str ->  output_tb.Text <- output_tb.Text + str) 
 
 
///Buttonへの関数登録 
 
//補助ウィンドウのボタンへの登録 
subInput_btn.Click.Add (fun _ -> inputForm.Close()) 
 
//メインウィンドウのボタンへの登録 
 
wsrc_load_btn.Click.Add 
    (fun _ -> try 
                let ofd = new OpenFileDialog(Filter = "WSファイル(*.ws)|*.ws|すべてのファイル(*.*)|*.*") 
                if(ofd.ShowDialog() = DialogResult.OK) then 
                    use sr = new System.IO.StreamReader(ofd.FileName) 
                    wSource_tb.Text <- sr.ReadToEnd() 
              with 
                | ex -> error_tb.Text <- ex.Message 
    ) 
 
wsrc_save_btn.Click.Add 
    (fun _ -> try 
                let sfd = new SaveFileDialog(Filter = "WSファイル(*.ws)|*.ws|すべてのファイル(*.*)|*.*", 
                                              RestoreDirectory = true) 
                if (sfd.ShowDialog() = DialogResult.OK) then 
                    use sw = new System.IO.StreamWriter(sfd.FileName) 
                    sw.Write(wSource_tb.Text) 
              with 
                | ex -> error_tb.Text <- ex.Message 
                 
    ) 
 
 
ws_cls_btn.Click.Add 
    (fun _ -> wSource_tb.Clear()) 
 
w2stn_btn.Click.Add 
    (fun _ -> stnSource_tb.Text <- (visualize (wSource_tb.Text)) 
        ) 
stn2w_btn.Click.Add 
    (fun _ -> wSource_tb.Text <- (unvisualize (stnSource_tb.Text)) 
        ) 
 
stn2c_btn.Click.Add 
   (fun _ -> clear_error_tb () 
             command_lb.Items.Clear() 
             try 
                let commandArr = makeCArray ComKindLst (stnSource_tb.Text) 
                resistered_ComArr <- commandArr  
                commandArr 
                |> Array.mapi(fun i x -> command_lb.Items.Add (sprintf "%4d: %A" i x)) 
                |>ignore 
             with 
                | ex -> error_tb.Text <- ex.Message 
              )   
  
c2stn_btn.Click.Add 
    (fun _ ->  stnSource_tb.Text <-(command2Stn resistered_ComArr)) 
 
STN_cls_btn.Click.Add 
    (fun _ -> stnSource_tb.Clear()) 
 
 
run_btn.Click.Add 
    (fun _ ->  clear_error_tb () 
               clear_log_lb () 
               clear_output_tb () 
               sbForLog.Clear() |> ignore 
               if resistered_ComArr.Length = 0 then 
                    error_tb.Text <- "コードが空です" 
               else 
                  try 
                    processCmd resistered_ComArr (0,[],Map.empty,[]) 
                    log_tb.Text <- sbForLog.ToString()   
                  with 
                    | ex -> error_tb.Text <- ex.Message 
        )                              
 
e2c_btn.Click.Add 
   (fun _ -> clear_error_tb () 
             command_lb.Items.Clear() 
             try 
                let commandArr = AnotherMakeCArr AnnotherComKindLst (editor_tb.Text) 
                resistered_ComArr <- commandArr  
                commandArr 
                |> Array.mapi(fun i x -> command_lb.Items.Add (sprintf "%4d: %A" i x)) 
                |>ignore 
             with 
                | ex -> error_tb.Text <- ex.Message 
              )   
[<STAThread()>]  
do Application.Run(mainForm)  
 
スポンサーサイト

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

コメントの投稿

非公開コメント

プロフィール

T GYOUTEN

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

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

この人とブロともになる

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