forked from LexiFi/gen_js_api
-
Notifications
You must be signed in to change notification settings - Fork 0
/
calc.ml
159 lines (127 loc) · 4.5 KB
/
calc.ml
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
module Element = [%js:
type t
val t_of_js: Ojs.t -> t
val append_child: t -> t -> unit [@@js.call]
val set_attribute: t -> string -> string -> unit [@@js.call]
val set_onclick: t -> (unit -> unit) -> unit [@@js.set]
]
module Window = [%js:
type t
val instance: t [@@js.global "window"]
val set_onload: t -> (unit -> unit) -> unit [@@js.set]
]
module Document = [%js:
type t
val instance: t [@@js.global "document"]
val create_element: t -> string -> Element.t [@@js.call]
val create_text_node: t -> string -> Element.t [@@js.call]
val body: t -> Element.t [@@js.get]
]
let element tag children =
let elt = Document.create_element Document.instance tag in
List.iter (Element.append_child elt) children;
elt
let textnode s = Document.create_text_node Document.instance s
let td ?colspan child =
let elt = element "td" [child] in
begin match colspan with
| None -> ()
| Some n -> Element.set_attribute elt "colspan" (string_of_int n)
end;
elt
let tr = element "tr"
let table = element "table"
let center x = element "center" [x]
let button x f =
let elt = element "button" [textnode x] in
Element.set_attribute elt "type" "button";
Element.set_onclick elt f;
elt
module Engine = struct
type op = Add | Sub | Mul | Div
type state =
{
x: float;
y: float;
operator: op option;
input: bool;
equal: bool;
comma: int;
}
let initial = { x = 0.; y = 0.; operator = None; input = false; equal = false; comma = 0 }
let make_op op x y =
match op with
| Add -> x +. y
| Sub -> x -. y
| Mul -> x *. y
| Div -> x /. y
let of_digit d = float_of_int d
let add_digit x comma d =
if comma = 0 then 10. *. x +. float_of_int d, comma
else x +. float_of_int d /. (10. ** (float_of_int comma)), comma + 1
let input_digit ({x; y; operator = _; input; equal; comma} as state) d =
let y = if equal then y else x in
let x, comma =
if input then add_digit x comma d
else of_digit d, 0
in
{state with x; y; comma; input = true}
let apply_comma ({input; comma; _} as state) =
if comma = 0 then
if input then {state with comma = 1}
else {(input_digit state 0) with comma = 1}
else state
let apply_equal ({x; y; operator; input; equal; comma = _} as state) =
match operator with
| None -> {state with y = x; input = false; equal = true}
| Some o ->
if input && not equal then {state with x = make_op o y x; y = x; input = false; equal = true}
else {state with x = make_op o x y; equal = true}
let apply_op ({input; equal; _} as state) op =
if input && not equal then {(apply_equal state) with operator = Some op; equal = false}
else {state with operator = Some op; equal= false; input = false}
let print_op ppf = function
| None -> Printf.fprintf ppf " "
| Some Add -> Printf.fprintf ppf "+"
| Some Sub -> Printf.fprintf ppf "-"
| Some Mul -> Printf.fprintf ppf "*"
| Some Div -> Printf.fprintf ppf "/"
let print ppf {x; y; operator; input; equal; comma} =
Printf.fprintf ppf "x = %g, y = %g, op = %a, input = %b, equal = %b, comma = %d" x y print_op operator input equal comma
end
let widget () =
let open Engine in
let state = ref initial in
let res, set_value =
let elt = element "input" [] in
Element.set_attribute elt "type" "text";
Element.set_attribute elt "readonly" "";
let set_value v = Element.set_attribute elt "value" (string_of_float v) in
elt, set_value
in
let update st =
Printf.printf "%a\n" print st;
state := st;
set_value !state.x
in
let reset() = update initial in
reset();
let binop op () = update (apply_op !state op) in
let equal () = update (apply_equal !state) in
let comma () = update (apply_comma !state) in
let figure digit =
let f () = update (input_digit !state digit) in
button (string_of_int digit) f
in
let c l = td l in
let nothing () = element "div" [] in
table [tr [td ~colspan:4 res];
tr (List.map c [nothing(); button "C" reset; nothing(); button "/" (binop Div)]);
tr (List.map c [figure 7; figure 8; figure 9; button "*" (binop Mul)]);
tr (List.map c [figure 4; figure 5; figure 6; button "-" (binop Sub)]);
tr (List.map c [figure 1; figure 2; figure 3; button "+" (binop Add)]);
tr (List.map c [nothing(); figure 0; button "." comma; button "=" equal])]
let go () =
Element.append_child (Document.body Document.instance) (center (widget()))
let () =
Window.set_onload Window.instance go