brainf-k-interpreter-fp.ml

module type Base = sig
  type ('x,'a) m
  val unit : 'a -> ('x,'a) m
  val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
end

module type BaseT = sig
  module W : Base
  type ('x,'a) m
  val lift : ('x,'a) W.m -> ('x,'a) m
  val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
end

module Monad = struct
  module Make(B: Base) = struct
    include B
    let (>>=) = bind
    let (>>) x y = x >>= fun _ -> y
    let sequence xs =
      List.fold_right (fun x y -> x >>= fun x' -> y >>= fun y' ->
        x'::y' |> unit) xs (unit [])
  end
  module MakeT(T: BaseT) = struct
    include Make(struct
      include T
      let unit a = W.unit a |> lift
    end)
    let lift = T.lift
  end
end

module State_monad(Store : sig type store end) = struct
  type store = Store.store
  module Base = struct
    type ('x,'a) m = store -> 'a * store
    let unit a = fun s -> (a, s)
    let bind x y = fun s -> let a, s' = x s in y a s'
  end
  include Monad.Make(Base)
  let get = fun s -> s, s
  let put s = fun _ -> (), s
  module T(W: Base) = struct
    include Monad.MakeT(struct
      module W = W
      type ('x,'a) m = store -> ('x,'a * store) W.m
      let lift w = fun s ->
        W.bind w (fun a -> W.unit (a,s))
      let bind x f = fun s ->
        W.bind (x s) (fun (a,s') -> f a s')
    end)
    let get = fun s -> W.unit (s, s)
    let put s = fun _ -> W.unit ((), s)
  end
end

module Maybe_monad = struct
  module Base = struct
    type ('x,'a) m = 'a option
    let unit x = Some x
    let bind x y = match x with
      | None -> None
      | Some x' -> y x'
    let zero () = None
  end
  include Monad.Make(Base)
  module T(W: Base) = struct
    include Monad.MakeT(struct
      module W = W
      type ('x,'a) m = ('x,'a option) W.m
      let lift w = W.bind w (fun a -> Some a |> W.unit)
      let bind x f = W.bind x (fun a -> match a with
        | None -> W.unit None
        | Some a' -> f a'
      )
    end)
    let zero () = W.unit None
  end
end

type ast = Chain of ast list | Loop of ast | Op of char

let parse s =
  let n = String.length s in
  let rec go acc i =
    if i >= n || s.[i] = ']' then
      Chain (List.rev acc), i
    else if s.[i] = '[' then
      let o, i' = go [] (i+1) in
      go (Loop o::acc) (i'+1)
    else
      go (Op s.[i]::acc) (i+1)
  in
  go [] 0 |> fst

module M = State_monad(struct type store = int * int list * int list * string * int * char list end)
module MM = Maybe_monad.T(M)

let tape f = MM.lift (fun (c,ls,rs,is,i,os) ->
  let ls, rs = f ls rs in
  ((), (c+1,ls,rs,is,i,os)))

let repeat n x =
  let rec go acc n =
    if n = 0 then
      acc
    else
      go (x::acc) (n-1)
  in
  go [] n

let init is = (0,[],repeat 100001 0,is,0,[])

let tick _ =
  MM.(lift M.get >>= fun (c,ls,rs,is,i,os) ->
    M.put (c+1,ls,rs,is,i,os) |> lift)

let rec eval ast =
  MM.(lift M.get >>= fun (c,ls,(x::rs' as rs),is,i,os) ->
    if c >= 100000 then
      zero ()
    else
      match ast with
      | Op '+' ->
          tape (fun ls (x::rs) -> ls, (x+1) land 255::rs)
      | Op '-' ->
          tape (fun ls (x::rs) -> ls, (x-1) land 255::rs)
      | Op '<' ->
          tape (fun (x::ls) rs -> ls, x::rs)
      | Op '>' ->
          tape (fun ls (x::rs) -> x::ls, rs)
      | Op '.' ->
          M.put (c+1,ls,rs,is,i,char_of_int x::os) |> lift
      | Op ',' ->
          M.put (c+1,ls,int_of_char is.[i]::rs',is,i+1,os) |> lift
      | Op _ ->
          unit ()
      | Chain ch ->
          List.map eval ch |> sequence >> unit ()
      | Loop ch ->
          tick () >>
          (if x <> 0 then
            eval ch >> tick () >>
            (lift M.get >>= fun (c,_,(x::_ as rs),_,_,_) ->
              if x <> 0 then
                eval ast
              else
                unit ())
          else
            tick ())
  )

let () =
  let s = read_line () in
  let _, m = Scanf.sscanf s "%d %d" (fun x y -> x,y) in
  let is = read_line () in
  let lines = Array.init m (fun _ -> read_line ()) in
  let program = String.make (Array.fold_left (fun x s -> x + String.length s) 0 lines) '.' in
  let rec fill i j =
    if i < m then (
      let l = String.length lines.(i) in
      String.blit lines.(i) 0 program j l;
      fill (i+1) (j+l)
    )
  in
  fill 0 0;
  let ast = parse program in
  match eval ast (init is) with
  | None, (_,_,_,_,_,os) ->
      List.rev os |> List.iter print_char;
      print_endline "\nPROCESS TIME OUT. KILLED!!!"
  | Some (), (_,_,_,_,_,os) ->
      List.rev os |> List.iter print_char