1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
open Mlpost
module P = Path
module N = Num
open Point
let ( |> ) x f = f x
let red dir distmax distmin =
let l = dir |> length |> N.minn (N.bp distmax) |> N.maxn (N.bp distmin) in
scale l (normalize dir)
let little_man ~phead ~plhand ~prhand ~plfoot ~prfoot =
let downbody = origin in
let upbody = bpp (0., 1.) in
let armfac = 0.75 in
let body = P.pathp [ downbody; upbody ] in
let dneck = sub phead upbody in
let neck, head =
let red = red dneck 0.75 0.25 in
(add (scale (N.bp (0.5 /. 0.75)) red) upbody, add red upbody)
in
let head = P.fullcircle |> P.scale (N.bp 0.5) |> P.shift head in
let neck = P.pathp [ neck; upbody ] in
let handbody = scale (N.bp armfac) upbody in
let pos anchor dir = add anchor (red (sub dir anchor) 1. 0.10) in
let hand dir =
let c = P.fullcircle |> P.scale (N.bp 0.1) in
let p = pos handbody dir in
(P.shift p c, p)
in
let lhand, plhand = hand plhand in
let rhand, prhand = hand prhand in
let foot dir =
let c = P.fullcircle |> P.scale (N.bp 0.1) in
let p = pos origin dir in
(P.shift p c, p)
in
let lfoot, plfoot = foot plfoot in
let rfoot, prfoot = foot prfoot in
let larm = P.pathp [ handbody; plhand ] in
let rarm = P.pathp [ handbody; prhand ] in
let lleg = P.pathp [ origin; plfoot ] in
let rleg = P.pathp [ origin; prfoot ] in
[ body; head; neck; larm; rarm; lhand; rhand; lfoot; rleg; lleg; rfoot ]
let rot p i = rotate (360. *. i) p
let rot_lit i =
little_man
~phead:(rot (bpp (0., 2.)) i)
~plhand:(rot (bpp (-2., 1.)) i)
~prhand:(rot (bpp (2., 1.)) i)
~plfoot:(rot (bpp (-2., -1.)) i)
~prfoot:(rot (bpp (2., -1.)) i)
|> List.map (P.scale (N.cm 1.))
|> List.map P.draw |> Command.seq
(*let () = List.iter (fun (s,f) -> Metapost.emit s f)
["little_man0", rot_lit 0.;
"little_man1", rot_lit 0.1;
"little_man2", rot_lit 0.2;
"little_man3", rot_lit 0.3;
"little_man4", rot_lit 0.4;]
*)
let _ = GMain.Main.init ()
let width = ref 400
let height = ref 400
let new_pixmap width height =
let drawable = GDraw.pixmap ~width ~height () in
drawable#set_foreground `WHITE;
drawable#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
drawable
let pm = ref (new_pixmap !width !height)
let need_update = ref true
let init_time = Unix.gettimeofday ()
let fps =
let nb = ref 0 in
let time = ref (Unix.time ()) in
fun () ->
let time2 = Unix.time () in
if time2 -. !time > 1. then (
Format.printf "fps : %i@." !nb;
nb := 0;
time := time2 )
else incr nb
let paint () =
let cr = Cairo_lablgtk.create !pm#pixmap in
!pm#rectangle ~x:0 ~y:0 ~width:!width ~height:!height ~filled:true ();
let w, h = (float_of_int !width, float_of_int !height) in
let i = Unix.gettimeofday () -. init_time in
let fig = rot_lit i in
let fig = Picture.shift (ptp (w /. 2., h /. 2.)) fig in
fps ();
Cairost.emit_cairo cr (w, h) fig
let refresh da =
need_update := true;
GtkBase.Widget.queue_draw da#as_widget
let grow_pixmap () =
pm := new_pixmap !width !height;
need_update := true
(* no need to queue a redraw here, an expose
event should follow the configure, right ? *)
let config_cb ev =
let w = GdkEvent.Configure.width ev in
let h = GdkEvent.Configure.height ev in
let has_grown = w > !width || h > !height in
width := w;
height := h;
if has_grown then grow_pixmap ();
true
let expose da x y width height =
let gwin = da#misc#window in
let d = new GDraw.drawable gwin in
d#put_pixmap ~x ~y ~xsrc:x ~ysrc:y ~width ~height !pm#pixmap
let expose_cb da ev =
let area = GdkEvent.Expose.area ev in
let module GR = Gdk.Rectangle in
if !need_update then paint ();
expose da (GR.x area) (GR.y area) (GR.width area) (GR.height area);
refresh da;
true
let button_ev da ev =
match GdkEvent.get_type ev with
| `BUTTON_RELEASE ->
refresh da;
true
| _ -> false
let init packing =
let da = GMisc.drawing_area ~width:!width ~height:!height ~packing () in
da#misc#set_can_focus true;
da#event#add [ `KEY_PRESS; `BUTTON_MOTION; `BUTTON_PRESS; `BUTTON_RELEASE ];
ignore (da#event#connect#expose (expose_cb da));
ignore (da#event#connect#configure config_cb);
ignore (da#event#connect#button_release (button_ev da))
let main =
let w =
GWindow.window ~title:"Cairo spline demo" ~allow_grow:true
~allow_shrink:true ()
in
ignore (w#connect#destroy GMain.quit);
init w#add;
w#show ();
GMain.main ()
|
