Skip to content

Instantly share code, notes, and snippets.

@ytomino

ytomino/grass.ml

Created July 29, 2011 05:04
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save ytomino/1113165 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save ytomino/1113165 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. aghia05 revised this gist Nov 18, 2008. 1 changed file with 17 additions and 17 deletions.
    34 changes: 17 additions & 17 deletions grass.ml
    View file
    Original file line number Diff line number Diff line change
    @@ -26,19 +26,18 @@ let rec scan s i = (
    | _ -> scan s (i + 1)
    );;

    type value = char option * func
    and func = Func of (value -> value);;
    type value = Value of char option * (value -> value);;

    let interpret stack source = (
    let rec interpret stack source ((index, token) as position) = (
    let rec apply stack f a = (
    match stack with
    | s :: sr ->
    if a = 1 then (
    let _, Func func = List.nth stack (f - 1) in
    let Value (_, func) = List.nth stack (f - 1) in
    func s
    ) else if f = 1 then (
    let _, Func func = s in
    let Value (_, func) = s in
    let arg = List.nth stack (a - 1) in
    func arg
    ) else (
    @@ -73,13 +72,14 @@ let interpret stack source = (
    let rec loop stack body = (
    match body with
    | [] -> List.hd stack
    | (f, a) :: [] -> apply stack f a
    | (f, a) :: br -> loop ((apply stack f a) :: stack) br
    ) in loop stack body
    ) else (
    None, Func (bind (n - 1) stack)
    Value (None, bind (n - 1) stack)
    )
    ) in
    let r = None, Func (bind argc stack) in
    let r = Value (None, bind argc stack) in
    interpret (r :: stack) source position
    | T_W ->
    (* 関数適用 *)
    @@ -101,23 +101,23 @@ let interpret stack source = (
    interpret stack source (find_first source)
    );;

    let true_f = None, Func (fun x -> None, Func (fun _ -> x));;
    let false_f = None, Func (fun _ -> None, Func (fun y -> y));;
    let true_f = Value (None, fun x -> Value (None, fun _ -> x));;
    let false_f = Value (None, fun _ -> Value (None, fun y -> y));;

    let char_f x = Some x, Func (fun y ->
    let char_f x = Value (Some x, fun y ->
    match y with
    | Some y, _ -> if x = y then true_f else false_f
    | Value (Some y, _) -> if x = y then true_f else false_f
    | _ -> raise (Failure "In equal, argument is not char!\n"));;

    let init_stack = [
    None, Func (function
    | (Some c, _) as a -> print_char c; if c = '\n' then flush stdout; a
    | None, _ -> raise (Failure "In primitive out, argument is not char!\n"));
    None, Func (function
    | Some c, _ -> char_f (char_of_int ((int_of_char c + 1) mod 256))
    | None, _ -> raise (Failure "In primitive succ, argument is not char!\n"));
    Value (None, function
    | Value (Some c, _) as a -> print_char c; if c = '\n' then flush stdout; a
    | _ -> raise (Failure "In primitive out, argument is not char!\n"));
    Value (None, function
    | Value (Some c, _) -> char_f (char_of_int ((int_of_char c + 1) mod 256))
    | _ -> raise (Failure "In primitive succ, argument is not char!\n"));
    char_f 'w';
    None, Func (fun x -> try char_f (input_char stdin) with End_of_file -> x)];;
    Value (None, fun x -> try char_f (input_char stdin) with End_of_file -> x)];;

    let read_all filename = (
    let f = open_in_bin filename in
  2. aghia05 revised this gist Nov 18, 2008. 1 changed file with 77 additions and 75 deletions.
    152 changes: 77 additions & 75 deletions grass.ml
    View file
    Original file line number Diff line number Diff line change
    @@ -1,102 +1,104 @@
    type value = char option * func
    and func = Func of (value -> value);;

    let sub_eq sub s i = (
    let rec loop sub j s i c = (
    if c <= 0 then true else
    if sub.[j] <> s.[i] then false else
    loop sub (j + 1) s (i + 1) (c - 1)
    ) in
    let sub_length = String.length sub in
    if i + sub_length > String.length s then false else
    loop sub 0 s i sub_length
    );;
    type token = T_w | T_W | T_v | EOF;;

    let peek half full s i = (
    let rec scan s i = (
    let length = String.length s in
    if i >= length then i else
    if s.[i] = half then i + 1 else
    let full_length = String.length full in
    if i + full_length > length then i else
    if sub_eq full s i then i + full_length else i
    if i >= length then length, EOF else
    match s.[i] with
    | 'W' -> i + 1, T_W
    | 'w' -> i + 1, T_w
    | 'v' -> i + 1, T_v
    | '\xef' -> (* Ｗ : EF BC B7, ｖ : EF BD 96, ｗ : EF BD 97 *)
    if i + 2 >= length then length, EOF else
    begin match s.[i + 1] with
    | '\xbc' ->
    begin match s.[i + 2] with
    | '\xb7' -> i + 3, T_W
    | _ -> scan s (i + 3)
    end
    | '\xbd' ->
    begin match s.[i + 2] with
    | '\x96' -> i + 3, T_v
    | '\x97' -> i + 3, T_w
    | _ -> scan s (i + 3)
    end
    | _ -> scan s (i + 3)
    end
    | _ -> scan s (i + 1)
    );;

    let peek_w = peek 'w' "ｗ";;
    let peek_W = peek 'W' "Ｗ";;
    let peek_v = peek 'v' "ｖ";;

    let find_first peek s = (
    let rec loop peek s i = (
    if i >= String.length s then i else
    let r = peek s i in
    if r > i then i else
    loop peek s (i + 1)
    ) in
    loop peek s 0
    );;
    type value = char option * func
    and func = Func of (value -> value);;

    let interpret stack source = (
    let rec interpret stack source index = (
    let rec read peek source index n = (
    let r = peek source index in
    if r > index then (
    read peek source r (n + 1)
    ) else if peek_w source index > index
    || peek_W source index > index
    || peek_v source index > index
    then (
    index, n
    ) else if index < String.length source then (
    read peek source (index + 1) n (* skip *)
    let rec interpret stack source ((index, token) as position) = (
    let rec apply stack f a = (
    match stack with
    | s :: sr ->
    if a = 1 then (
    let _, Func func = List.nth stack (f - 1) in
    func s
    ) else if f = 1 then (
    let _, Func func = s in
    let arg = List.nth stack (a - 1) in
    func arg
    ) else (
    apply sr (f - 1) (a - 1)
    )
    | [] -> raise (Failure "Stack underflow!\n")
    ) in
    let rec read target source ((index, token) as position) n = (
    if token = target then (
    read target source (scan source index) (n + 1)
    ) else (
    index, n
    position, n
    )
    ) in
    let rec read_body source index body = (
    let (index, f) = read peek_W source index 0 in
    if f = 0 then (index, List.rev body) else
    let (index, a) = read peek_w source index 0 in
    read_body source index ((f, a) :: body)
    ) in
    let apply stack f a = (
    let (_, Func func) = List.nth stack (f - 1) in
    let arg = List.nth stack (a - 1) in
    func arg
    let rec read_body source position body = (
    let position, f = read T_W source position 0 in
    if f = 0 then (position, List.rev body) else
    let position, a = read T_w source position 0 in
    read_body source position ((f, a) :: body)
    ) in
    if index >= String.length source then (
    match token with
    | EOF ->
    (* 最後に来たらApply(1,1)して終了 *)
    let _ = apply stack 1 1 in ()
    ) else if peek_w source index > index then (
    | T_w ->
    (* 関数定義 *)
    let (index, argc) = read peek_w source index 0 in
    (* Printf.printf "%d:\n" argc; flush stdout; *)
    let (index, body) = read_body source index [] in
    let rec make stack n = (
    if n = 0 then (
    let position, argc = read T_w source position 0 in
    let position, body = read_body source position [] in
    let rec bind n stack arg = (
    let stack = arg :: stack in
    if n = 1 then (
    let rec loop stack body = (
    match body with
    | [] -> List.hd stack
    | (f, a) :: br -> loop ((apply stack f a) :: stack) br
    ) in loop stack body
    ) else (
    None, Func (fun a -> make (a :: stack) (n - 1))
    None, Func (bind (n - 1) stack)
    )
    ) in
    let r = make stack argc in
    interpret (r :: stack) source index
    ) else if peek_W source index > index then (
    let r = None, Func (bind argc stack) in
    interpret (r :: stack) source position
    | T_W ->
    (* 関数適用 *)
    let (index, f) = read peek_W source index 0 in
    let (index, a) = read peek_w source index 0 in
    (* Printf.printf " %d %d\n" f a; flush stdout; *)
    let position, f = read T_W source position 0 in
    let position, a = read T_w source position 0 in
    let r = apply stack f a in
    interpret (r :: stack) source index
    ) else (
    (* 無視 *)
    interpret stack source (index + 1)
    )
    interpret (r :: stack) source position
    | T_v -> interpret stack source (scan source index) (* skip *)
    ) in
    let find_first s = (
    let rec loop s i = (
    let (j, t) as r = scan s i in
    match t with
    | T_w | EOF -> r
    | _ -> loop s j
    ) in
    loop s 0
    ) in
    interpret stack source (find_first peek_w source);
    interpret stack source (find_first source)
    );;

    let true_f = None, Func (fun x -> None, Func (fun _ -> x));;
  3. aghia05 created this gist Nov 18, 2008.
    130 changes: 130 additions & 0 deletions grass.ml
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,130 @@
    type value = char option * func
    and func = Func of (value -> value);;

    let sub_eq sub s i = (
    let rec loop sub j s i c = (
    if c <= 0 then true else
    if sub.[j] <> s.[i] then false else
    loop sub (j + 1) s (i + 1) (c - 1)
    ) in
    let sub_length = String.length sub in
    if i + sub_length > String.length s then false else
    loop sub 0 s i sub_length
    );;

    let peek half full s i = (
    let length = String.length s in
    if i >= length then i else
    if s.[i] = half then i + 1 else
    let full_length = String.length full in
    if i + full_length > length then i else
    if sub_eq full s i then i + full_length else i
    );;

    let peek_w = peek 'w' "ｗ";;
    let peek_W = peek 'W' "Ｗ";;
    let peek_v = peek 'v' "ｖ";;

    let find_first peek s = (
    let rec loop peek s i = (
    if i >= String.length s then i else
    let r = peek s i in
    if r > i then i else
    loop peek s (i + 1)
    ) in
    loop peek s 0
    );;

    let interpret stack source = (
    let rec interpret stack source index = (
    let rec read peek source index n = (
    let r = peek source index in
    if r > index then (
    read peek source r (n + 1)
    ) else if peek_w source index > index
    || peek_W source index > index
    || peek_v source index > index
    then (
    index, n
    ) else if index < String.length source then (
    read peek source (index + 1) n (* skip *)
    ) else (
    index, n
    )
    ) in
    let rec read_body source index body = (
    let (index, f) = read peek_W source index 0 in
    if f = 0 then (index, List.rev body) else
    let (index, a) = read peek_w source index 0 in
    read_body source index ((f, a) :: body)
    ) in
    let apply stack f a = (
    let (_, Func func) = List.nth stack (f - 1) in
    let arg = List.nth stack (a - 1) in
    func arg
    ) in
    if index >= String.length source then (
    (* 最後に来たらApply(1,1)して終了 *)
    let _ = apply stack 1 1 in ()
    ) else if peek_w source index > index then (
    (* 関数定義 *)
    let (index, argc) = read peek_w source index 0 in
    (* Printf.printf "%d:\n" argc; flush stdout; *)
    let (index, body) = read_body source index [] in
    let rec make stack n = (
    if n = 0 then (
    let rec loop stack body = (
    match body with
    | [] -> List.hd stack
    | (f, a) :: br -> loop ((apply stack f a) :: stack) br
    ) in loop stack body
    ) else (
    None, Func (fun a -> make (a :: stack) (n - 1))
    )
    ) in
    let r = make stack argc in
    interpret (r :: stack) source index
    ) else if peek_W source index > index then (
    (* 関数適用 *)
    let (index, f) = read peek_W source index 0 in
    let (index, a) = read peek_w source index 0 in
    (* Printf.printf " %d %d\n" f a; flush stdout; *)
    let r = apply stack f a in
    interpret (r :: stack) source index
    ) else (
    (* 無視 *)
    interpret stack source (index + 1)
    )
    ) in
    interpret stack source (find_first peek_w source);
    );;

    let true_f = None, Func (fun x -> None, Func (fun _ -> x));;
    let false_f = None, Func (fun _ -> None, Func (fun y -> y));;

    let char_f x = Some x, Func (fun y ->
    match y with
    | Some y, _ -> if x = y then true_f else false_f
    | _ -> raise (Failure "In equal, argument is not char!\n"));;

    let init_stack = [
    None, Func (function
    | (Some c, _) as a -> print_char c; if c = '\n' then flush stdout; a
    | None, _ -> raise (Failure "In primitive out, argument is not char!\n"));
    None, Func (function
    | Some c, _ -> char_f (char_of_int ((int_of_char c + 1) mod 256))
    | None, _ -> raise (Failure "In primitive succ, argument is not char!\n"));
    char_f 'w';
    None, Func (fun x -> try char_f (input_char stdin) with End_of_file -> x)];;

    let read_all filename = (
    let f = open_in_bin filename in
    let size = in_channel_length f in
    let result = String.make size '\x00' in
    really_input f result 0 size;
    close_in f;
    result
    );;

    let filename = Sys.argv.(1) in
    interpret init_stack (read_all filename);;