ほむ。F#でプログラミング言語「ほむほむ」して、さらに「ほむほむ」した
元ネタは、ゆろよろさんの
プログラミング言語「ほむほむ」 - ゆろよろ日記(id:yuroyoro)
http://d.hatena.ne.jp/yuroyoro/20110601/1306908421
F#でプログラミング言語「ほむほむ」
以前実装したF#でGrassなプログラムをちょっと改造しただけの手抜きだが、
F#でプログラミング言語「ほむほむ」実装した。
https://gist.github.com/1002805
open System type token = Tw | TW | Tv | EoF type Value = Value of char option * (Value -> Value) let Write = let queue = new System.Collections.Generic.Queue<byte> () (fun _ (c : char) -> let (|HEIGHT|_|) x = match x with | x when x >= 0x81uy && x <= 0x9Fuy || x >= 0xE0uy -> Some x | _ -> None let (|LOW|_|) x = match x with | x when x >= 0x40uy && x <= 0x7Euy || x >= 0x80uy && x <= 0xFCuy -> Some x | _ -> None match c |> byte with | HEIGHT x when queue.Count = 0 -> x |> queue.Enqueue | LOW x when queue.Count <> 0 -> [|queue.Dequeue (); x|] |> System.Text.Encoding.GetEncoding(932).GetString |> Console.Write | _ -> Console.Write c) () let Char x = Value (Some x, fun y -> let True = Value (None, fun x -> Value (None, fun _ -> x)) let False = Value (None, fun _ -> Value (None, fun y -> y)) match y with | Value (Some y, _) -> match x,y with | x,y when x = y -> True | _ -> False | _ -> raise (new ArgumentException("Char : char以外はだめ"))) let InitStack = [ Value (None, function | Value (Some c, _) as v -> Write c; v | _ -> raise (new ArgumentException("primitive Out : char以外はだめ"))); Value (None, function | Value (Some c, _) -> (int c + 1) % 256 |> char |> Char | _ -> raise (new ArgumentException("primitive Succ : char以外はだめ"))); Char 'w'; Value (None, fun x -> try stdin.ToString() |> char |> Char with eof -> x)] let Stack = (fun _ -> let stack = ref InitStack fun x -> match x with | [] -> !stack | _ -> stack := x @ !stack; !stack) () open System.Text.RegularExpressions let rx = new Regex(@"\r\n|ほむ|(?<homu>[\s|\t]+[ほむ{1,}]+[\s$|\t$])") let ReadFile filename = System.IO.File.ReadAllText(filename,System.Text.Encoding.GetEncoding("SHIFT-JIS")) let source = let source = @"c:\Code\ほむほむ\ほむほむ.txt" |> ReadFile seq { for s in rx.Matches(source) do let s = s.ToString() if s = "ほむ" then yield 'w' elif Regex.IsMatch(s,"[\s|\t]+[ほむ{1,}]+[\s$|\t$]") then for s in Regex.Matches(s,"ほむ") do yield 'W' elif s = "\r\n" then yield 'v' } |> Seq.toArray let rec Analyze i = let (|EOF|_|) x = match x with | x when x >= source.Length -> Some x | _ -> None match i with | EOF i -> i, EoF | _ -> match source.[i] with | 'w' -> i + 1, Tw | 'W' -> i + 1, TW | 'v' -> i + 1, Tv | _ -> Analyze (i + 1) let rec Read target (index, token as position) i = match token,target with | token,target when token = target -> Read target (Analyze index) (i + 1) | _ -> position, i let rec ReadBody position body = let position, f = Read TW position 0 match f with | 0 -> (position, List.rev body) | _ -> let position, a = Read Tw position 0 ReadBody position ((f, a) :: body) let rec App f a stack = match stack with | [] -> raise (new ArgumentException("stack")) | v::st -> match a,f with | 1,_ -> let Value = List.nth stack (f - 1) match Value with | Value (c,func) -> func v | _,1 -> let arg = List.nth stack (a - 1) let value = List.nth stack (f - 1) match value with | Value (c,func) -> func arg | _ -> st |> App (f - 1) (a - 1) let Run = let rec Run (index, token as position) = match token with | EoF -> [] |> Stack |> App 1 1 |> ignore | Tw -> let position, argc = Read Tw position 0 let position, body = ReadBody position [] let rec bind n stack arg = let stack = arg :: stack match n with | 1 -> let rec loop stack body = match body with | [] -> List.head stack | (f, a) :: [] -> stack |> App f a | (f, a) :: br -> loop ((stack |> App f a) :: stack) br loop stack body | _ -> Value (None, bind (n - 1) stack) [Value (None, bind argc (Stack[]))] |> Stack |> ignore Run position | TW -> let position, f = Read TW position 0 let position, a = Read Tw position 0 [Stack [] |> App f a] |> Stack |> ignore Run position | Tv -> Run (Analyze index) let start = let rec loop i = let (index, token) as result = Analyze i match token with | Tw | EoF -> result | _ -> loop index loop 0 start |> Run [<STAThreadAttribute>] do Run; stdin.ReadLine () |> ignore
以前、F#でちょっと草植えた記事はこちら
http://d.hatena.ne.jp/zecl/20100418/p1
オリジナルのほむほむのコードを書いてみる。
プログラミング言語「ほむほむ」で「ほむほむ」と出力してみる。
ほむほむ.txt
ほむ ほむほむ ほむほむ ほむ ほむほむほむ ほむ ほむ ほむほむほむほむ ほむほむ ほむ ほむほむほむ ほむ ほむほむほむほむ ほむ ほむほむほむほむほむ ほむ ほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむ ほむ ほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむほむほむ ほむ ほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむ ほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむほむ ほむほむほむほむ
実行結果
ほむほむ
ほむほむ。実にほむほむですね。
ほむほむでほむほむできました。わーいやたーー\(^o^)/
追伸:オープンソースカンファレンス 2011 Hokkaidoに参加します。
のぶひささん(id:Nobuhisa)にお誘いいただきまして、OSC 2011 Hokkaidoに「F# User Group - Japan」のメンバーとして参加します。
セミナーを受講していないときは展示ブースにおりますのでので、ぜひお立ち寄りいただけたらと思います。
展示用のアプリ(F#+Silverlightな何か)を持参する予定です。よろしくお願いします。
もちろん、のぶひささんのセッションは見逃せません!!