open Graphics;; exception Replay of string type drawing = Commit | Set_color of int | Plot of int * int | Moveto of int * int | Lineto of int * int | Draw_arc of int * int * int * int * int * int | Draw_ellipse of int * int * int * int | Draw_circle of int * int * int | Set_line_width of int | Draw_char of char | Draw_string of string | Set_font of string | Set_text_size of int | Fill_rect of int * int * int * int | Fill_poly of (int * int) array | Fill_arc of int * int * int * int * int * int | Fill_ellipse of int * int * int * int | Fill_circle of int * int * int | Draw_image of image * int * int | Blit_image of image * int * int | Sound of int * int ;; let play = function | Set_color c -> set_color c | Plot (u,v) -> plot u v | Moveto (u, v) -> moveto u v | Lineto (u,v) -> lineto u v | Draw_arc (x1, y1, x2, y2, x3, y3) -> draw_arc x1 y2 x2 y2 x3 y3 | Draw_ellipse (x1, y1, x2, y2) -> draw_ellipse x1 y1 x2 y2 | Draw_circle (x1, x2, x3) -> draw_circle x1 x2 x3 | Set_line_width x -> set_line_width x | Draw_char c -> draw_char c | Draw_string s -> draw_string s | Set_font s -> set_font s | Set_text_size n -> set_text_size n | Fill_rect (x1, y1, x2, y2) -> fill_rect x1 y1 x2 y2 | Fill_poly t -> fill_poly t | Fill_arc (x1, y1, x2, y2, x3, y3) -> fill_arc x1 y1 x2 y2 x3 y3 | Fill_ellipse (x1, y1, x2, y2) -> fill_ellipse x1 y1 x2 y2 | Fill_circle (x, y, r) -> fill_circle x y r | Draw_image (i, x, y) -> draw_image i x y | Blit_image (i, x, y) -> blit_image i x y | Sound (x, y) -> sound x y ;; let tape = ref [||];; let time = ref (-1);; let last = ref (-1);; let step = ref [];; let basis = ref None;; let clear_tape() = tape := [||]; step := []; time := -1; last := -1; basis := None;; let get_basis()= match !basis with None -> let i = get_image 0 0 (size_x()) (size_y()) in basis := Some i; i | Some s -> s ;; let save() = clear_tape(); blit_image (get_basis()) (size_x()) (size_y());; let restore() = draw_image (get_basis()) 0 0;; let rec rotate_left k left right = if k = 0 then (left, right) else match left with [] -> left, right | h :: t -> rotate_left (pred k) t (h::right) ;; let end_of_tape() = (!time = !last);; let rec commit() = if not (end_of_tape()) then resume(); if !time = -1 then begin save() end; incr time; incr last; if !last = Array.length !tape then begin let new_tape = Array.create ((1 + Array.length !tape) * 2) ([] (*< , get_image 0 0 1 1 >*)) in Array.blit !tape 0 new_tape 0 !last; tape := new_tape; end; !tape.(!last) <- List.rev !step (*<, get_image 0 0 (size_x()) (size_y()) >*); step := [] and forward k = if !step <> [] then commit(); let t = min !last (!time + k) in for i = !time + 1 to t do List.iter play !tape.(i) done; time := t; (*< draw_image (snd !tape.(t)) 0 0 >*) and resume() = forward (!last - !time);; let backward k = if !step <> [] then commit(); let t = max 0 (!time -k) in time := t; set_color white; restore(); for i = 0 to t do List.iter play !tape.(i) done (*< draw_image (snd !tape.(t)) 0 0 >*) ;; let beginning() = backward !time;; let goto t = if t > !time then forward (t - !time) else backward (!time - t);; let record d = if not (end_of_tape()) then resume(); step := d :: !step; play d; ;; let set_color c = record (Set_color c) let plot u v = record (Plot (u,v)) let moveto u v = record (Moveto (u, v)) let lineto u v = record (Lineto (u,v)) let draw_arc x1 y1 x2 y2 x3 y3 = record (Draw_arc (x1, y1, x2, y2, x3, y3)) let draw_ellipse x1 y1 x2 y2 = record (Draw_ellipse (x1, y1, x2, y2)) let draw_circle x y r = record (Draw_circle (x, y, r)) let set_line_width x = record (Set_line_width x) let draw_char c = record (Draw_char c) let draw_string s = record (Draw_string s) let set_font s = record (Set_font s) let set_text_size n = record (Set_text_size n) let fill_rect x1 y1 x2 y2 = record (Fill_rect (x1, y1, x2, y2)) let fill_poly t = record (Fill_poly t) let fill_arc x1 y1 x2 y2 x3 y3 = record (Fill_arc (x1, y1, x2, y2, x3, y3)) let fill_ellipse x1 y1 x2 y2 = record (Fill_ellipse (x1, y1, x2, y2)) let fill_circle x y r = record (Fill_circle (x, y, r)) let draw_image i x y = record (Draw_image (i, x, y)) let blit_image i x y = record (Blit_image (i, x, y)) let sound x y = record (Sound (x, y))