module SExpr : sig
  (** This module is a very simple parsing library for S-expressions. *)
  (* Copyright (C) 2009  Florent Monnier, released under MIT license. *)

  (** the type of S-expressions *)
  type sexpr =
    | Atom of string
    | Expr of sexpr list

  val parse_string : string -> sexpr list
  (** parse from a string *)

  (** {3 Printing} *)

  val print_sexpr : sexpr list -> unit
  (** a dump function for the type [sexpr] *)

  val print_sexpr_indent : sexpr list -> unit
  (** same than [print_sexpr] but with indentation *)

  val string_of_sexpr : sexpr list -> string
  (** convert an expression of type [sexpr] into a string *)

  val string_of_sexpr_indent : sexpr list -> string
  (** same than [string_of_sexpr] but with indentation *)
  (** This module is a very simple parsing library for S-expressions. *)

end = struct

type sexpr = Atom of string | Expr of sexpr list
 
type state =
  | Parse_root of sexpr list
  | Parse_content of sexpr list
  | Parse_word of Buffer.t * sexpr list
  | Parse_string of bool * Buffer.t * sexpr list
 
let parse pop_char =
  let rec aux st =
    match pop_char () with
    | None ->
        begin match st with
        | Parse_root sl -> (List.rev sl)
        | Parse_content _ ->
            failwith "Parsing error: content not closed by parenthesis"
        | Parse_word _ ->
            failwith "Parsing error: word not closed by parenthesis"
        | Parse_string _ ->
            failwith "Parsing error: string content not closed by parenthesis"
        end
    | Some c ->
        match c, st with
        | ';', Parse_root _
        | ';', Parse_content _
        | ';', Parse_word _ ->
            let rec remove_comment () =
              match pop_char () with
              | Some '\n' | None -> aux st
              | _ -> remove_comment ()
            in
            remove_comment ()
        | _ ->
            match c with
            | '(' ->
                begin match st with
                | Parse_root sl ->
                    let this = aux (Parse_content []) in
                    aux (Parse_root((Expr this)::sl))
                | Parse_content sl ->
                    let this = aux (Parse_content []) in
                    aux (Parse_content((Expr this)::sl))
                | Parse_word(w, sl) ->
                    let this = aux (Parse_content []) in
                    aux (Parse_content((Expr this)::Atom(Buffer.contents w)::sl))
                | Parse_string(_, s, sl) ->
                    Buffer.add_char s c;
                    aux (Parse_string(false, s, sl))
                end
            | ')' ->
                begin match st with
                | Parse_root _ ->
                    failwith "Parsing error: closing parenthesis without openning"
                | Parse_content sl -> (List.rev sl)
                | Parse_word(w, sl) -> List.rev(Atom(Buffer.contents w)::sl)
                | Parse_string(_, s, sl) ->
                    Buffer.add_char s c;
                    aux (Parse_string(false, s, sl))
                end
            | ' ' | '\n' | '\r' | '\t' ->
                begin match st with
                | Parse_root sl -> aux (Parse_root sl)
                | Parse_content sl -> aux (Parse_content sl)
                | Parse_word(w, sl) -> aux (Parse_content(Atom(Buffer.contents w)::sl))
                | Parse_string(_, s, sl) ->
                    Buffer.add_char s c;
                    aux (Parse_string(false, s, sl))
                end
            | '"' ->
                begin match st with
                | Parse_root _ -> failwith "Parse error: double quote at root level"
                | Parse_content sl ->
                    let s = Buffer.create 74 in
                    aux (Parse_string(false, s, sl))
                | Parse_word(w, sl) ->
                    let s = Buffer.create 74 in
                    aux (Parse_string(false, s, Atom(Buffer.contents w)::sl))
                | Parse_string(true, s, sl) ->
                    Buffer.add_char s c;
                    aux (Parse_string(false, s, sl))
                | Parse_string(false, s, sl) ->
                    aux (Parse_content(Atom(Buffer.contents s)::sl))
                end
            | '\\' ->
                begin match st with
                | Parse_string(true, s, sl) ->
                    Buffer.add_char s c;
                    aux (Parse_string(false, s, sl))
                | Parse_string(false, s, sl) ->
                    aux (Parse_string(true, s, sl))
                | _ ->
                    failwith "Parsing error: escape character in wrong place"
                end
            | _ ->
                begin match st with
                | Parse_root _ ->
                    failwith(Printf.sprintf "Parsing error: char '%c' at root level" c)
                | Parse_content sl ->
                    let w = Buffer.create 16 in
                    Buffer.add_char w c;
                    aux (Parse_word(w, sl))
                | Parse_word(w, sl) ->
                    Buffer.add_char w c;
                    aux (Parse_word(w, sl))
                | Parse_string(_, s, sl) ->
                    Buffer.add_char s c;
                    aux (Parse_string(false, s, sl))
                end
  in
  aux (Parse_root [])
 
 
let string_pop_char str =
  let len = String.length str in
  let i = ref (-1) in
  function () ->
    incr i;
    if !i >= len
    then None
    else Some (String.unsafe_get str !i)
 
 
let parse_string str =
  parse (string_pop_char str)
 

let quote s =
  "\"" ^ s ^ "\""
 
let needs_quote s =
  List.exists (String.contains s) [' '; '\n'; '\r'; '\t'; '('; ')']
 
let protect s =
  let s = String.escaped s in
  if needs_quote s then quote s else s
 
 
let string_of_sexpr s =
  let rec aux acc = function
  | (Atom tag)::tl -> aux ((protect tag)::acc) tl
  | (Expr e)::tl ->
      let s =
        "(" ^
        (String.concat " " (aux [] e))
        ^ ")"
      in
      aux (s::acc) tl
  | [] -> (List.rev acc)
  in
  String.concat " " (aux [] s)
 
 
let print_sexpr s =
  print_endline (string_of_sexpr s)
 
 
let string_of_sexpr_indent s =
  let rec aux i acc = function
  | (Atom tag)::tl -> aux i ((protect tag)::acc) tl
  | (Expr e)::tl ->
      let s =
        "\n" ^ (String.make i ' ') ^ "(" ^
        (String.concat " " (aux (succ i) [] e))
        ^ ")"
      in
      aux i (s::acc) tl
  | [] -> (List.rev acc)
  in
  String.concat "\n" (aux 0 [] s)
 
 
let print_sexpr_indent s =
  print_endline (string_of_sexpr_indent s)

end

(* small scheme-like language *)
open SExpr

type primitive =
  | Unit
  | Int of int
  | Float of float
  | Bool of bool
  | String of bytes
  | Char of char
  | Fun of (string list * sexpr)
  | Lst of primitive list
  | Arr of primitive array
  | Mut of primitive ref
  | Obj of (string * primitive) list
  | Err of string

let rec val_string v =
  match v with
  | Int d -> Printf.sprintf "Int(%d)" d
  | Float f -> Printf.sprintf "Float(%f)" f
  | Bool b -> Printf.sprintf "Bool(%b)" b
  | Char c -> Printf.sprintf "Char(%c)" c
  | String s -> Printf.sprintf "String(\"%s\")" (Bytes.unsafe_to_string s)
  | Unit -> Printf.sprintf "Unit()"
  | Err e -> Printf.sprintf "Error(%s)" e
  | Fun _ -> Printf.sprintf "Fun(...)"
  | Lst l -> Printf.sprintf "Lst(%s)" (String.concat ", " (List.map val_string l))
  | Arr a -> Printf.sprintf "Arr(%s)" (String.concat "; " (List.map val_string (Array.to_list a)))
  | Mut m -> Printf.sprintf "Mut(%s)" (val_string !m)
  | Obj _ -> Printf.sprintf "Obj(...)"

let rec string_val = function
  | Int d -> Printf.sprintf "%d" d
  | Float f -> Printf.sprintf "%f" f
  | Bool b -> Printf.sprintf "%b" b
  | Char c -> Printf.sprintf "%c" c
  | Unit -> Printf.sprintf "()"
  | Err e -> Printf.sprintf "<error:%s>" e
  | Fun _ -> Printf.sprintf "fun<>"
  | String s -> Printf.sprintf "\"%s\"" (Bytes.unsafe_to_string s)
  | Lst l -> Printf.sprintf "lst<%s>" (String.concat ":" (List.map string_val l))
  | Arr a -> Printf.sprintf "arr<%s>" (String.concat "|" (List.map string_val (Array.to_list a)))
  | Mut m -> Printf.sprintf "mut<%s>" (string_val !m)
  | Obj _ -> Printf.sprintf "obj<..>"

type prim = primitive
type arity =
  | Ari1 of (prim -> prim)
  | Ari2 of ((prim * prim) -> prim)
  | Ari3 of ((prim * prim * prim) -> prim)
  | Ari4 of ((prim * prim * prim * prim) -> prim)
  | AriN of ((prim list) -> prim)

let ( ^ ) = Bytes.cat ;;
let s0 = Bytes.create 0 ;;
let b = Buffer.create 110 ;;

let pi = 3.14159265358979312 ;;

let () = Random.self_init () ;;

module Canvas = Canvas2

type sprite = {
  sx: int;
  sy: int;
  w: int;
  h: int;
  name: string;
}

let sprites = [
  { sx = 48; sy = 34; w = 15; h = 16; name = "abs-12a" };
  { sx = 37; sy = 0;  w = 16; h = 17; name = "abs-12b" };
  { sx = 20; sy = 17; w = 16; h = 17; name = "abs-12c" };
  { sx = 20; sy = 0;  w = 17; h = 17; name = "abs-12d" };
  { sx = 0;  sy = 50; w = 16; h = 15; name = "abs-12e" };
  { sx = 0;  sy = 18; w = 15; h = 17; name = "abs-12f" };
  { sx = 15; sy = 34; w = 17; h = 16; name = "abs-12g" };
  { sx = 0;  sy = 0;  w = 20; h = 18; name = "abs-12h" };
  { sx = 32; sy = 34; w = 16; h = 16; name = "abs-12i" };
  { sx = 36; sy = 17; w = 16; h = 17; name = "abs-12j" };
]

let canvas = Canvas.getElementById Canvas.doc "my_canvas" ;;
let ctx = Canvas.getContext canvas "2d" ;;

let () = Canvas.imageSmoothingEnabled ctx false ;;

let sprites_tex = "./atlas-2025-06-13_1.png"
let sprites_texture = Canvas.newImage ()
let () = Canvas.setImgSrc sprites_texture sprites_tex ;;


let rec find_map f = function
  | [] -> None
  | x :: l ->
     begin match f x with
       | Some _ as result -> result
       | None -> find_map f l
     end

let range1 a b =
  let rec aux acc i =
    if i < a then acc else aux ((Int i)::acc) (i - 1)
  in
  aux [] b

let range2 a b =
  let rec aux acc i =
    if i > a then acc else aux ((Int i)::acc) (i + 1)
  in
  aux [] b

let range a b =
  if a < b
  then range1 a b
  else range2 a b

let alias (_, f) fn = (fn, f)

let f_eq = "=",
  Ari2 (function (v1, v2) ->
  (if v1 = v2 then Bool (true) else Bool (false))
  )

let f_not = "!",
  Ari1 (function (v) ->
  match (v) with
  | Bool b -> Bool (not b)
  | _ -> Err("invalid-arg:!")
  )

let f_lt = "<",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Float f1, Float f2 -> Bool (f1 < f2)
  | Int d1, Int d2 -> Bool (d1 < d2)
  | _, _ -> Err("invalid-arg:<")
  )

let f_gt = ">",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Float f1, Float f2 -> Bool (f1 > f2)
  | Int d1, Int d2 -> Bool (d1 > d2)
  | _, _ -> Err("invalid-arg:>")
  )

let f_diff = "<>",
  Ari2 (function (v1, v2) ->
  (Bool (v1 <> v2))
  )

let f_and = "and",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Bool b1, Bool b2 -> Bool (b1 && b2)
  | _ -> Err("invalid-arg:and")
  )

let f_or = "or",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Bool b1, Bool b2 -> Bool (b1 || b2)
  | _ -> Err("invalid-arg:or")
  )

let f_randint = "rand_int",
  Ari1 (function (v) ->
  match (v) with
  | Int d -> Int (Random.int d)
  | _ -> Err("invalid-arg:rand_int")
  )

let f_draw_sprite = "draw_sprite",
  Ari3 (function (v1, v2, v3) ->
  match (v1, v2, v3) with
  | Int x, Int y, String s ->
    let n = Bytes.unsafe_to_string s in
    begin try
      let sprite = List.find (fun sprite -> sprite.name = n) sprites in
      let sx = sprite.sx in
      let sy = sprite.sy in
      let w, h = sprite.w, sprite.h in
      let sw, sh = w, h in
      let dw, dh = w, h in
      let dx, dy = (x, y) in
      Canvas.drawImage8 ctx sprites_texture sx sy sw sh dx dy dw dh;
      (Unit)
    with Not_found ->
      Err("invalid-arg:draw_sprite")
    end
  | _ -> Err("invalid-arg:draw_sprite")
  )

let f_draw_rect = "draw_rect",
  Ari4 (function (v1, v2, v3, v4) ->
  match (v1, v2, v3, v4) with
  | Int x, Int y, Int w, Int h ->
    begin
      let color = "rgb(220, 220, 240)" in
      Canvas.fillStyle ctx color;
      Canvas.fillRect ctx x y w h;
    end;
    (Unit)
  | _ -> Err("invalid-arg:draw_rect")
  )

let f_draw_circ = "draw_circ",
  Ari3 (function (v1, v2, v3) ->
  try
    let cx = match v1 with Int cx -> (float_of_int cx) | Float cx -> (cx) | _ -> raise Exit in
    let cy = match v2 with Int cy -> (float_of_int cy) | Float cy -> (cy) | _ -> raise Exit in
    let r = match v3 with Int r -> (float_of_int r) | Float r -> (r) | _ -> raise Exit in
    begin
      let color = "rgb(220, 220, 240)" in
      Canvas.beginPath ctx;
      Canvas.fillStyle ctx color;
      Canvas.arc ctx cx cy r 0.0 (2.0 *. pi);
      Canvas.fill ctx;
    end;
    (Unit)
  with Exit ->
    Err("invalid-arg:draw_circ")
  )

let f_draw_text = "draw_text",
  Ari3 (function (v1, v2, v3) ->
  match (v1, v2, v3) with
  | Int x, Int y, String s ->
    begin
      let color = "rgb(220, 220, 240)" in
      Canvas.font ctx "bold 16px Arial";
      Canvas.fillStyle ctx color;
      Canvas.fillText ctx (Bytes.unsafe_to_string s) x y;
    end;
    (Unit)
  | _ -> Err("invalid-arg:draw_text")
  )

let f_plus = "+",
  AriN (function vs ->
    let vs = List.map (function Int d -> d | _ -> invalid_arg "+") vs in
    let v = List.fold_left ( + ) 0 vs in
    (Int v)
  )

let f_plusf = "+.",
  AriN (function vs ->
    let vs = List.map (function Float f -> f | _ -> invalid_arg "+.") vs in
    let v = List.fold_left ( +. ) 0.0 vs in
    (Float v)
  )

let f_minus = "-",
  AriN (function vs ->
    let vs = List.map (function Int d -> d | _ -> invalid_arg "-") vs in
    let v, vs = match vs with v::[] -> (0, [v]) | v::vs -> (v, vs) | [] -> (0, [0]) in
    let v = List.fold_left ( - ) v vs in
    (Int v)
  )

let f_minusf = "-.",
  AriN (function vs ->
    let vs = List.map (function Float f -> f | _ -> invalid_arg "-.") vs in
    let v, vs = match vs with v::[] -> (0.0, [v]) | v::vs -> (v, vs) | [] -> (0.0, [0.0]) in
    let v = List.fold_left ( -. ) v vs in
    (Float v)
  )

let f_mult = "*",
  AriN (function vs ->
    let vs = List.map (function Int d -> d | _ -> invalid_arg "*") vs in
    let v = List.fold_left ( * ) 1 vs in
    (Int v)
  )

let f_multf = "*.",
  AriN (function vs ->
    let vs = List.map (function Float f -> f | _ -> invalid_arg "*.") vs in
    let v = List.fold_left ( *. ) 1.0 vs in
    (Float v)
  )

let f_div = "/",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Int d1, Int d2 -> Int (d1 / d2)
  | _, _ -> Err("invalid-arg:div")
  )

let f_divf = "/.",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Float f1, Float f2 -> Float (f1 /. f2)
  | _, _ -> Err("invalid-arg:divf")
  )

let f_cat = "^",
  AriN (function vs ->
  let cat vs =
    let vs = List.map (function String s -> s | _ -> invalid_arg "^") vs in
    let s = List.fold_left ( ^ ) s0 vs in
    (String s)
  in
  match vs with
  | [Lst l] -> cat l
  | [Arr a] -> cat (Array.to_list a)
  | vs -> cat vs
  )

let f_print = "print",
  AriN (function vs ->
    (Buffer.add_string b) ">";
    List.iter (fun v ->
      match v with
      | Lst l ->
          List.map (fun v -> Printf.sprintf " %s" (string_val v)) l
          |> String.concat "," |> (Buffer.add_string b)
      | Arr a ->
          Array.map (fun v -> Printf.sprintf " %s" (string_val v)) a
          |> Array.to_list |> String.concat ";" |> (Buffer.add_string b)
      | _ ->
          Printf.kprintf (Buffer.add_string b) " %s" (string_val v);
    ) vs;
    (Buffer.add_string b) "\n";
    (Unit)
  )

let f_substr = "substr",
  Ari3 (function (v1, v2, v3) ->
  match (v1, v2, v3) with
  | String s, Int d1, Int d2 -> String (Bytes.sub s d1 d2)
  | _, _, _ -> Err("invalid-arg:substr")
  )

let f_strget = "strget",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | String s, Int d -> Char (Bytes.get s d)
  | _, _ -> Err("invalid-arg:strget")
  )

let f_strlen = "strlen",
  Ari1 (function v ->
  match v with
  | String s -> Int (Bytes.length s)
  | _ -> Err("invalid-arg:strlen")
  )

let f_strset = "strset",
  Ari3 (function (v1, v2, v3) ->
  match (v1, v2, v3) with
  | String s, Int d, Char c -> (Bytes.set s d c; Unit)
  | _, _, _ -> Err("invalid-arg:strset")
  )

let f_strmake = "strmake",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Int d, Char c -> String (Bytes.unsafe_of_string (String.make d c))
  | _ -> Err("invalid-arg:strmake")
  )

let f_incr = "incr",
  Ari1 (function (v) ->
  match (v) with
  | Int d -> Int (d + 1)
  | _ -> Err("invalid-arg:incr")
  )

let f_decr = "decr",
  Ari1 (function (v) ->
  match (v) with
  | Int d -> Int (d - 1)
  | _ -> Err("invalid-arg:decr")
  )

let f_ref = "ref",
  Ari1 (function v ->
  Mut (ref v)
  )

let f_deref = "deref",
  Ari1 (function v ->
  match (v) with
  | Mut v -> !v
  | _ -> Err("invalid-arg:deref")
  )

let f_refset = "refset",
  Ari2 (function (v1, v2) ->
  match (v1) with
  | Mut v -> v := v2; (Unit)
  | _ -> Err("invalid-arg:refset")
  )

let f_isint = "is_int",
  Ari1 (function (v) ->
  match (v) with
  | Int _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_isfloat = "is_float",
  Ari1 (function (v) ->
  match (v) with
  | Float _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_islst = "is_lst",
  Ari1 (function (v) ->
  match (v) with
  | Lst _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_isarr = "is_arr",
  Ari1 (function (v) ->
  match (v) with
  | Arr _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_isstr = "is_str",
  Ari1 (function (v) ->
  match (v) with
  | String _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_ischr = "is_char",
  Ari1 (function (v) ->
  match (v) with
  | Char _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_isbool = "is_bool",
  Ari1 (function (v) ->
  match (v) with
  | Bool _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_isfun = "is_fun",
  Ari1 (function (v) ->
  match (v) with
  | Fun _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_iserr = "is_err",
  Ari1 (function (v) ->
  match (v) with
  | Err _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_isunit = "is_unit",
  Ari1 (function (v) ->
  match (v) with
  | Unit -> Bool (true)
  | _ -> Bool (false)
  )

let f_isobj = "is_obj",
  Ari1 (function (v) ->
  match (v) with
  | Obj _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_ismut = "is_ref",
  Ari1 (function (v) ->
  match (v) with
  | Mut _ -> Bool (true)
  | _ -> Bool (false)
  )

let f_range = "range",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Int a, Int b -> Lst (range a b)
  | _, _ -> Err("invalid-arg:range")
  )

let f_arange = "#range",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Int a, Int b -> Arr (Array.of_list (range a b))
  | _, _ -> Err("invalid-arg:#range")
  )

let f_arrget = "arrget",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Arr a, Int d -> (Array.get a d)
  | _ -> Err("invalid-arg:arrget")
  )

let f_arrset = "arrset",
  Ari3 (function (v1, v2, v3) ->
  match (v1, v2) with
  | Arr a, Int d -> Array.set a d v3; (Unit)
  | _ -> Err("invalid-arg:arrset")
  )

let f_toarray = "#<",
  Ari1 (function (v) ->
  match (v) with
  | Lst l -> Arr (Array.of_list l)
  | _ -> Err("invalid-arg:to_array")
  )

let f_ofarray = "#>",
  Ari1 (function (v) ->
  match (v) with
  | Arr a -> Lst (Array.to_list a)
  | _ -> Err("invalid-arg:of_array")
  )

let f_lstlen = "lstlen",
  Ari1 (function (v) ->
  match (v) with
  | Lst l -> Int (List.length l)
  | _ -> Err("invalid-arg:lstlen")
  )

let f_lstget = "lstget",
  Ari2 (function (v1, v2) ->
  match (v1, v2) with
  | Lst l, Int d -> (List.nth l d)
  | _ -> Err("invalid-arg:lstget")
  )

let f_rev = "rev",
  Ari1 (function (v) ->
  match (v) with
  | Lst l -> Lst (List.rev l)
  | _ -> Err("invalid-arg:rev")
  )

let f_cons = "cons",
  Ari2 (function (v1, v2) ->
  match (v2) with
  | Lst l -> Lst (v1 :: l)
  | _ -> Err("invalid-arg:cons")
  )

let f_tail = "tl",
  AriN (function vs ->
  match vs with
  | [Lst l] ->
    (match l with _::l -> Lst (l)
     | [] -> Err("invalid-arg:tl"))
  | _::vs -> Lst vs
  | [] -> Err("invalid-arg:tl")
  )

let f_head = "hd",
  AriN (function vs ->
  match vs with
  | [Lst l] ->
    (match l with h::_ -> h
     | [] -> Err("invalid-arg:hd"))
  | h::_ -> h
  | [] -> Err("invalid-arg:hd")
  )

let f_arrlen = "arrlen",
  Ari1 (function (v) ->
  match (v) with
  | Arr a -> Int (Array.length a)
  | _ -> Err("invalid-arg:arrlen")
  )

let f_len = "len",
  Ari1 (function (v) ->
  match (v) with
  | Lst l -> Int (List.length l)
  | Arr a -> Int (Array.length a)
  | _ -> Err("invalid-arg:len")
  )

let f_sqrt = "sqrt",
  Ari1 (function Float f -> Float (sqrt f) | _ -> Err("invalid-arg:sqrt"))

let f_cos = "cos",
  Ari1 (function Float f -> Float (cos f) | _ -> Err("invalid-arg:cos"))

let f_sin = "sin",
  Ari1 (function Float f -> Float (sin f) | _ -> Err("invalid-arg:sin"))

let f_float = "float",
  Ari1 (function Int d -> Float (float_of_int d) | _ -> Err("invalid-arg:float"))

let f_int = "int",
  Ari1 (function Float f -> Int (int_of_float f) | _ -> Err("invalid-arg:int"))

let fs = Array.to_list [|
  f_draw_sprite;
  f_draw_rect;
  f_draw_circ;
  f_draw_text;
  f_randint;
  f_print;
  f_substr;
  f_strget;
  f_strlen;
  f_strset;
  f_strmake;
  f_arrget;
  f_arrset;
  f_sqrt;
  f_float;
  f_int;
  f_plus;
  f_plusf;
  f_minus;
  f_minusf;
  f_mult;
  f_multf;
  f_div;
  f_divf;
  alias f_plus "plus";
  alias f_div "div";
  f_cos;
  f_sin;
  f_cat;
  f_eq;
  f_lt;
  f_gt;
  f_not;
  f_diff;
  alias f_print ".<";
  alias f_cat "cat";
  alias f_eq "eq";
  alias f_lt "lt";
  alias f_gt "gt";
  alias f_not "!";
  alias f_diff "!=";
  alias f_and "&&";
  alias f_or "||";
  alias f_arrget "#[]";
  alias f_arrset "#[]<";
  alias f_strget ".[]";
  f_lstget;
  alias f_lstget ":[]";
  alias f_cons "::";
  f_range;
  f_arange;
  alias f_range "..";
  alias f_arange "#..";
  f_toarray;
  f_ofarray;
  f_lstlen;
  f_arrlen;
  f_len;
  f_rev;
  f_cons;
  f_tail;
  f_head;
  alias f_tail "_:";
  alias f_tail "tail";
  alias f_head "head";
  alias f_toarray "to_array";
  alias f_ofarray "of_array";
  alias f_ofarray "to_list";
  alias f_strmake "str_make";
  f_incr;
  f_decr;
  alias f_incr "++";
  alias f_decr "--";
  f_ref;
  f_deref;
  f_refset;
  alias f_ref ":=";
  alias f_deref "@";
  alias f_refset "<-";
  alias f_deref "refget";
  f_isint;
  f_isfloat;
  f_isarr;
  f_islst;
  f_isstr;
  f_ischr;
  f_isbool;
  f_isfun;
  f_iserr;
  f_isunit;
  f_isobj;
  f_ismut;
|]

let print_val vs =
  print_endline (val_string vs)

let print_vals vs =
  List.iter print_val vs

let print_env env =
  List.iter (fun (name, value) ->
    Printf.printf "# '%s': %s\n" name (val_string value)
  ) env

let is_fun fn env =
  match List.assoc_opt fn env with
  | None -> false
  | Some v ->
      match v with
      | Fun _ -> true
      | _ -> false

let is_bool s =
  match s with
  | "#t" -> Some (true)
  | "#f" -> Some (false)
  | _ -> None

let is_int s =
  try Some (int_of_string s)
  with _ -> None

let is_float s =
  try Some (float_of_string s)
  with _ -> None

let is_env v env =
  try Some (List.assoc v env)
  with _ -> None

let eval ps =
  let env = [] in
  let rec aux env p =
    match p with
    | Atom (a)
    | Expr [(Atom a)] ->
        begin match is_int a with
        | Some d -> (Int d, env)
        | None ->
            match is_float a with
            | Some f -> (Float f, env)
            | None ->
                match is_bool a with
                | Some b -> (Bool b, env)
                | None ->
                    match is_env a env with
                    | Some p -> (p, env)
                    | None -> (Err(Printf.sprintf "unknwon-atom(%s)" a), env)
        end

    | Expr [(Atom "fn"); (Atom name); Expr(se0); se] ->
        let prms = List.map (function Atom a -> a | _ -> invalid_arg "fn") se0 in
        let v = Fun(prms, se) in
        let env = (name, v) :: env in
        (Unit, env)

    | Expr ((Atom fn) :: se_p)
      when is_fun fn env ->
        begin match List.assoc fn env with
        | Fun(prms, se) ->
            let l1 = List.length se_p in
            let l2 = List.length prms in
            if l1 <> l2 then invalid_arg "fn:arg-len";
            let _env = List.fold_left2 (fun env p se -> let v, _ = aux env se in (p, v) :: env) env prms se_p in
            let v, _ = aux _env se in
            (v, env)
        | _ -> assert false
        end

    | Expr [(Atom "if"); cond; se1; se2] ->
        let c, _ = aux env cond in
        let v, _ =
          if c = Bool (true)
          then aux env se1
          else aux env se2
        in
        (v, env)

    | Expr [(Atom "if"); cond; se1] ->
        let c, _ = aux env cond in
        let v, _ =
          if c = Bool (true)
          then aux env se1
          else (Unit, [])
        in
        (v, env)

    | Expr [(Atom "define"); (Atom name); se] ->
        let v, _ = aux env se in
        let env = (name, v) :: env in
        (Unit, env)

    | Expr ((Atom fn)::se)
      when List.mem_assoc fn fs ->
        let fa = List.assoc fn fs in
        begin match fa, se with
        | Ari1 f, [se] ->
            let v, _ = aux env se in
            (f v), env
        | Ari2 f, [se1; se2] ->
            let v1, _ = aux env se1 in
            let v2, _ = aux env se2 in
            f (v1, v2), env
        | Ari3 f, [se1; se2; se3] ->
            let v1, _ = aux env se1 in
            let v2, _ = aux env se2 in
            let v3, _ = aux env se3 in
            f (v1, v2, v3), env
        | Ari4 f, [se1; se2; se3; se4] ->
            let v1, _ = aux env se1 in
            let v2, _ = aux env se2 in
            let v3, _ = aux env se3 in
            let v4, _ = aux env se4 in
            f (v1, v2, v3, v4), env
        | AriN f, tl ->
            let vs = List.map (fun se -> let v, _ = aux env se in v) tl in
            (f vs), env
        | _ ->
            Err("invalid-arg:arity"), env
        end

    | Expr [(Atom "iter"); (Atom f); tl]
      when List.mem_assoc f fs ->

        let fa = List.assoc f fs in
        begin match fa with
        | Ari1 f ->
            let vs, _ = aux env tl in
            begin match vs with
            | Lst vs -> Lst (List.map (fun v -> (f v)) vs)
            | Arr vs -> Arr (Array.map (fun v -> (f v)) vs)
            | _ -> Err("iter")
            end
            , env
        | AriN f ->
            let vs, _ = aux env tl in
            begin match vs with
            | Lst vs -> Lst (List.map (fun v -> (f [v])) vs)
            | Arr vs -> Arr (Array.map (fun v -> (f [v])) vs)
            | _ -> Err("iter")
            end
            , env
        | _ ->
            Err("invalid-arg:iter"), env
        end

    | Expr [(Atom "iter"); (Atom fn); tl]
      when is_fun fn env ->

        let f = List.assoc fn env in
        begin match f with
        | Fun(prms, se) ->
            if (List.length prms) <> 1 then invalid_arg "iter";
            let prm = List.nth prms 0 in
            let vs, _ = aux env tl in
            begin match vs with
            | Lst vs ->
                Lst (
                  List.map (fun v ->
                    let _env = (prm, v) :: env in
                    let v, _ = aux _env se in
                    (v)
                  ) vs
                )
            | Arr vs ->
                Arr (
                  Array.map (fun v ->
                    let _env = (prm, v) :: env in
                    let v, _ = aux _env se in
                    (v)
                  ) vs
                )
            | _ -> Err("iter")
            end
            , env
        | _ -> assert false
        end

    | Expr ((Atom "iter")::(Atom f)::tl)
      when List.mem_assoc f fs ->
        let se = Expr [(Atom "iter"); (Atom f); (Expr tl)] in
        let v, _ = aux env se in
        (v, env)

    | Expr ((Atom "iter")::(Atom fn)::tl)
      when is_fun fn env ->
        let se = Expr [(Atom "iter"); (Atom fn); (Expr tl)] in
        let v, _ = aux env se in
        (v, env)

    | Expr ((Atom "switch") :: se :: switch_se) ->
        let v, _ = aux env se in
        let res =
          find_map (fun se ->
            match se with
            | Expr ((Atom "default") :: se_assoc)
            | Expr ((Atom "_") :: se_assoc) ->
                let v_assoc, _ = aux env (Expr se_assoc) in
                Some (v_assoc)
            | Expr (se_case :: se_assoc) ->
                let v_case, _ = aux env se_case in
                if (v_case = v) then
                  let v_assoc, _ = aux env (Expr se_assoc) in
                  Some (v_assoc)
                else
                  None
            | _ -> None
          ) switch_se
        in
        begin match res with
        | Some v -> v
        | None -> Unit
        end
        , env

    | Expr [(Atom "obj"); (Expr se)] ->

        let fields =
          List.map (fun se ->
            match se with
            | Expr [(Atom field_name); se] ->
                let v, _ = aux env se in
                (field_name, v)
            | Expr ((Atom field_name)::_) ->
                (field_name, Err("def-obj-field"))
            | _ -> "", Err("obj-field")
          ) se
        in
        (Obj fields), env

    | Expr ((Atom "obj") :: tl) ->

        let se = Expr [(Atom "obj"); (Expr tl)] in
        let v, _ = aux env se in
        (v, env)

    | Expr [(Atom "objset"); (Atom obj_name); (Atom field_name); se] ->

        begin match List.assoc_opt obj_name env with
        | Some (Obj fields) ->
            let obj =
              Obj (
                List.map (fun ((f_name, _) as field) ->
                  if (f_name <> field_name)
                  then (field)
                  else let v, _ = aux env se in (f_name, v)
                ) fields
              )
            in
            let env = List.remove_assoc obj_name env in
            let env = (obj_name, obj) :: env in
            (Unit, env)

        | _ -> Err("obj-field-set"), env
        end

    | Expr [(Atom "objget"); (Atom obj_name); (Atom field_name)] ->

        begin match List.assoc_opt obj_name env with
        | Some (Obj obj) ->
          ( match List.assoc_opt field_name obj with
            | None -> Err("obj-field-get")
            | Some v -> v
          )
        | _ -> Err("obj-field-get:not-found")
        end,
        env

    | Expr [(Atom "objadd"); (Atom obj_name); (Atom field_name); se] ->

        begin match List.assoc_opt obj_name env with
        | Some (Obj fields) ->
            if List.mem_assoc field_name fields
            then Err("obj-field-add"), env else

            let obj =
              Obj (
                let v, _ = aux env se in
                (field_name, v) :: fields
              )
            in
            let env = List.remove_assoc obj_name env in
            let env = (obj_name, obj) :: env in
            (Unit, env)

        | _ -> Err("obj-field-add"), env
        end

    | Expr [(Atom "objhas"); (Atom obj_name); (Atom field_name)] ->

        begin match List.assoc_opt obj_name env with
        | Some (Obj fields) ->
            if (List.mem_assoc field_name fields)
            then (Bool true), env
            else (Bool false), env

        | _ -> Err("obj-field-has"), env
        end

    | Expr [(Atom "objrem"); (Atom obj_name); (Atom field_name)] ->

        begin match List.assoc_opt obj_name env with
        | Some (Obj fields) ->
            if not (List.mem_assoc field_name fields)
            then Err("obj-field-rem"), env else
            let obj =
              Obj (
                let fields = List.remove_assoc field_name fields in
                (fields)
              )
            in
            let env = List.remove_assoc obj_name env in
            let env = (obj_name, obj) :: env in
            (Unit, env)

        | _ -> Err("obj-field-rem"), env
        end

    | Expr [(Atom "for"); (Atom i); range; func_se] ->

        let r, _ = aux env range in
        begin match r with
        | Lst is ->
            Lst (
              List.map (fun _i ->
                let _env = (i, _i) :: env in
                let v, _ = aux _env func_se in
                (v)
              ) is
            )
        | Arr is ->
            Arr (
              Array.map (fun _i ->
                let _env = (i, _i) :: env in
                let v, _ = aux _env func_se in
                (v)
              ) is
            )
        | _ -> Err("for")
        end
        , env

    | Expr [(Atom "s"); Atom s]
    | Expr [(Atom "string"); Atom s] ->
        let s = Bytes.of_string s in
        (String s), env

    | Expr [(Atom "c"); Atom s]
    | Expr [(Atom "char"); Atom s] ->
        if (String.length s) <> 1 then Err("invalid-arg:char"), env else
        let c = String.get s 0 in
        (Char c), env

    (*
    | Expr ((Atom "print") :: tl) ->
        List.map (fun se ->
          let v, _ = aux env se in
          string_val v
        ) tl |> (String.concat ", ")
             |> Printf.kprintf (Buffer.add_string b) "> %s\n";
        (Unit, env)
    *)

    | Expr [] ->
        (Unit, env)
    | Expr ((Atom "#") :: se_lst) ->
        let vs = List.map (fun se -> let v, _ = aux env se in v) se_lst in
        let vs = Array.of_list vs in
        (Arr vs, env)

    | Expr (se_lst) ->
        let vs, _ = List.fold_left (fun (acc, env) se -> let v, _env = aux env se in (v::acc, _env)) ([], env) se_lst in
        let vs = List.rev vs in
        (Lst vs, env)
    (*
    | _ ->
        (Err "ToDo", env)
    *)
  in
  List.fold_left (fun (vs, env) p ->
    let v, env = aux env p in
    (v::vs, env)
  ) ([], env) ps

let clear_bg () =
  let color = "#191922" in
  Canvas.fillStyle ctx color;
  Canvas.fillRect ctx 0 0 480 290;
;;

let error_string e s =
  Buffer.clear b;
  Buffer.add_string b s;
  Buffer.add_string b e;
  let r = Buffer.contents b in
  Buffer.reset b;
  (r)

let main_f s =
  try
    let ps = parse_string s in
    let _, _ = eval ps in
    (*
    let vs, env = eval ps in
    let env, vs = (List.rev env, List.rev vs) in
    print_env env;
    print_vals vs;
    *)
    let r = Buffer.contents b in
    Buffer.reset b;
    (r)
  with
  | Invalid_argument e -> error_string e "Invalid_arg:"
  | Failure e -> error_string e "Failure:"

(*
let () =
  let s = {|
    (print (s "hello"))
  |} in
  let r = main_f s in
  print_endline r;
;;
*)