ほむほむ

homuhomu.fs

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