* with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-type 't interface_state = { n: int option; pos: int * int; current: 't }
-
-let render
- (type t)
- (m : (module Automata.Automaton with type t = t))
- (board : t Automata.board)
- (inter : t interface_state) =
- let module M = (val m) in
- for x = 0 to (Graphics.size_x () / 16) + 1 do
- for y = 0 to (Graphics.size_y () / 16) + 1 do
- let r, g, b = M.color (Automata.get x y board) in
- let r, g, b = (int_of_char r, int_of_char g, int_of_char b) in
- Graphics.set_color (Graphics.rgb r g b);
- Graphics.fill_rect (x * 16) (y * 16) 16 16;
- Graphics.set_color (Graphics.rgb 127 127 127);
- Graphics.draw_rect (x * 16) (y * 16) 16 16
- done
- done;
- let r, g, b = M.color inter.current in
- let r, g, b = (int_of_char r, int_of_char g, int_of_char b) in
- Graphics.set_color (Graphics.rgb r g b);
- Graphics.fill_rect ((fst inter.pos * 16) + 5) ((snd inter.pos * 16) + 5) 6 6;
- Graphics.set_color (Graphics.rgb 127 127 127);
- Graphics.draw_rect ((fst inter.pos * 16) + 5) ((snd inter.pos * 16) + 5) 6 6
-
-let inputs
- (type t)
- (m : (module Automata.Automaton with type t = t))
- (board : t Automata.board)
- (inter : t interface_state) =
- let set_current inter = Automata.set (fst inter.pos) (snd inter.pos) inter.current in
- let chpos dx dy ({ pos = x, y; _ } as inter) = { inter with pos = (x + dx, y + dy) } in
- let chcur f ({ current; _ } as inter) = { inter with current = f current } in
- let chnum d ({ n; _ } as inter) = { inter with n = Some ((Option.value n ~default:0 * 10) + d) } in
- let rec ntimes f ({ n; _ } as inter) =
- match Option.value n ~default:1 with
- | 0 -> { inter with n = None }
- | n -> f (ntimes f { inter with n = Some (n - 1) })
- in
- let rec ntimesb f (board, ({ n; _ } as inter)) =
- match Option.value n ~default:1 with
- | 0 -> (board, { inter with n = None })
- | n -> f (ntimesb f (board, { inter with n = Some (n - 1) }))
- in
- let module M = (val m) in
- if Graphics.key_pressed ()
- then
- match Graphics.read_key () with
- | c when '0' <= c && c <= '9' -> (board, chnum (int_of_char c - int_of_char '0') inter)
- | 's' -> (set_current inter board, inter)
- | 'q' -> (board, ntimes (chcur M.prev) inter)
- | 'd' -> (board, ntimes (chcur M.next) inter)
- | 'f' -> ntimesb (fun (b, i) -> (Automata.update m b, i)) (board, inter)
- | 'k' -> (board, ntimes (chpos 0 1) inter)
- | 'h' -> (board, ntimes (chpos (-1) 0) inter)
- | 'j' -> (board, ntimes (chpos 0 (-1)) inter)
- | 'l' -> (board, ntimes (chpos 1 0) inter)
- | _ -> (board, inter)
- else (board, inter)
-
-let run (type t) (m : (module Automata.Automaton with type t = t)) =
- let module M = (val m) in
- let rec aux board inter =
- render m board inter;
- Graphics.synchronize ();
- let board, inter = inputs m board inter in
- aux board inter
- in
- aux (Automata.initial m) { n = None; pos = (0, 0); current = M.default }
-
-let pick f cs =
- let rec aux above curr below =
- Graphics.clear_graph ();
- let x = 25
- and y = (Graphics.size_y () / 2) - 10 in
- let draw_text i s =
- Graphics.moveto x (y + (i * 25));
- Graphics.draw_string s
- in
- List.iteri (fun i -> draw_text (i + 1)) (List.map f above);
- draw_text 0 (f curr);
- Graphics.draw_rect (x - 5) (y - 5) 200 20;
- List.iteri (fun i -> draw_text (-i - 1)) (List.map f below);
+let run (type state) (m : (module Modes.Mode with type state = state)) =
+ let rec aux : type state. state -> (module Modes.Mode with type state = state) -> unit =
+ fun state m ->
+ let module M = (val m) in
+ M.render state;
Graphics.synchronize ();
if Graphics.key_pressed ()
then
- match Graphics.read_key () with
- | 'k' -> (
- match above with
- | [] -> aux [] curr below
- | c :: cs -> aux cs c (curr :: below))
- | 'j' -> (
- match below with
- | [] -> aux above curr []
- | c :: cs -> aux (curr :: above) c cs)
- | 's' -> curr
- | _ -> aux above curr below
- else aux above curr below
+ match M.update state (Graphics.read_key ()) with
+ | Either.Left state -> aux state m
+ | Either.Right m ->
+ let module M = (val m) in
+ aux M.initial (module M)
+ else aux state m
in
- match cs with
- | c :: cs -> aux [] c cs
- | [] -> assert false (* cs should be non-empty *)
+ let module M = (val m) in
+ aux M.initial m
let () =
Graphics.open_graph "";
Graphics.set_window_title "Automaton";
Graphics.auto_synchronize false;
- try
- let m =
- pick
- (fun m ->
- let module M = (val m : Automata.Automaton) in
- M.name)
- Automata.automata
- in
- let module M = (val m) in
- run (module M)
- with Graphics.Graphic_failure _ -> ()
+ try run (module Modes.AutoSelector) with Graphics.Graphic_failure _ -> ()
--- /dev/null
+(* Copyright 2024 Amélia COUTARD <https://www.ameliathe1st.gay>.
+ *
+ * This file from the program cells is free software: you can redistribute it and/or
+ * modify it under the terms of the GNU Affero General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but WITHOUT ANY
+ * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+ * PARTICULAR PURPOSE. See the GNU Affero General Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License along
+ * with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+module rec ModeAux : sig
+ module type S = sig
+ type state
+
+ val initial : state
+
+ val render : state -> unit
+
+ val update : state -> char -> (state, (module ModeAux.S)) Either.t
+ end
+end =
+ ModeAux
+
+module type Mode = ModeAux.S
+
+module Normal (M : Automata.Automaton) = struct
+ type state = { board: M.t Automata.board; n: int option; pos: int * int; current: M.t }
+
+ let initial = { board = Automata.initial (module M); n = None; pos = (0, 0); current = M.default }
+
+ let render { board; current; pos = px, py; _ } =
+ for x = 0 to (Graphics.size_x () / 16) + 1 do
+ for y = 0 to (Graphics.size_y () / 16) + 1 do
+ let r, g, b = M.color (Automata.get x y board) in
+ let r, g, b = (int_of_char r, int_of_char g, int_of_char b) in
+ Graphics.set_color (Graphics.rgb r g b);
+ Graphics.fill_rect (x * 16) (y * 16) 16 16;
+ Graphics.set_color (Graphics.rgb 127 127 127);
+ Graphics.draw_rect (x * 16) (y * 16) 16 16
+ done
+ done;
+ let r, g, b = M.color current in
+ let r, g, b = (int_of_char r, int_of_char g, int_of_char b) in
+ Graphics.set_color (Graphics.rgb r g b);
+ Graphics.fill_rect ((px * 16) + 5) ((py * 16) + 5) 6 6;
+ Graphics.set_color (Graphics.rgb 127 127 127);
+ Graphics.draw_rect ((px * 16) + 5) ((py * 16) + 5) 6 6
+
+ let update st =
+ let set_current ({ board; pos = x, y; current; _ } as st) =
+ { st with board = Automata.set x y current board }
+ in
+ let chpos dx dy ({ pos = x, y; _ } as st) = { st with pos = (x + dx, y + dy) } in
+ let chcur f st = { st with current = f st.current } in
+ let chnum d st = { st with n = Some ((Option.value st.n ~default:0 * 10) + d) } in
+ let rec ntimes f st =
+ match Option.value st.n ~default:1 with
+ | 0 -> { st with n = None }
+ | n -> f (ntimes f { st with n = Some (n - 1) })
+ in
+ function
+ | c when '0' <= c && c <= '9' -> Either.left (chnum (int_of_char c - int_of_char '0') st)
+ | 's' -> Either.left (set_current st)
+ | 'q' -> Either.left (ntimes (chcur M.prev) st)
+ | 'd' -> Either.left (ntimes (chcur M.next) st)
+ | 'f' -> Either.left (ntimes (fun st -> { st with board = Automata.update (module M) st.board }) st)
+ | 'k' -> Either.left (ntimes (chpos 0 1) st)
+ | 'h' -> Either.left (ntimes (chpos (-1) 0) st)
+ | 'j' -> Either.left (ntimes (chpos 0 (-1)) st)
+ | 'l' -> Either.left (ntimes (chpos 1 0) st)
+ | _ -> Either.left st
+end
+
+module AutoSelector = struct
+ type state = (module Automata.Automaton) list * (module Automata.Automaton) * (module Automata.Automaton) list
+
+ let initial =
+ match Automata.automata with
+ | au :: aus -> ([], au, aus)
+ | [] -> assert false
+
+ let render (above, curr, below) =
+ let auto_name (m : (module Automata.Automaton)) =
+ let module M = (val m) in
+ M.name
+ in
+ Graphics.clear_graph ();
+ let x = 25
+ and y = (Graphics.size_y () / 2) - 10 in
+ let draw_text i s =
+ Graphics.moveto x (y + (i * 25));
+ Graphics.draw_string s
+ in
+ List.iteri (fun i -> draw_text (i + 1)) (List.map auto_name above);
+ draw_text 0 (auto_name curr);
+ Graphics.draw_rect (x - 5) (y - 5) 200 20;
+ List.iteri (fun i -> draw_text (-i - 1)) (List.map auto_name below)
+
+ let update (above, curr, below) = function
+ | 'k' -> (
+ match above with
+ | [] -> Either.left ([], curr, below)
+ | c :: cs -> Either.left (cs, c, curr :: below))
+ | 'j' -> (
+ match below with
+ | [] -> Either.left (above, curr, [])
+ | c :: cs -> Either.left (curr :: above, c, cs))
+ | 's' ->
+ let module M = (val curr : Automata.Automaton) in
+ Either.right (module Normal (M) : Mode)
+ | _ -> Either.left (above, curr, below)
+end
--- /dev/null
+(* Copyright 2024 Amélia COUTARD <https://www.ameliathe1st.gay>.
+ *
+ * This file from the program cells is free software: you can redistribute it and/or
+ * modify it under the terms of the GNU Affero General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but WITHOUT ANY
+ * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+ * PARTICULAR PURPOSE. See the GNU Affero General Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License along
+ * with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+module rec ModeAux : sig
+ module type S = sig
+ type state
+
+ val initial : state
+
+ val render : state -> unit
+
+ val update : state -> char -> (state, (module ModeAux.S)) Either.t
+ end
+end
+
+module type Mode = ModeAux.S
+
+module Normal (_ : Automata.Automaton) : Mode
+
+module AutoSelector : Mode
projects / cells.git / commitdiff