Newer
Older
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
module AssocList = struct
type key = string
type 'a t = (string * 'a) list
let empty : 'a t = []
let put (k : key) (v : 'a) (a : 'a t) : 'a t = (k, v) :: a
let get : key -> 'a t -> 'a option = List.assoc_opt
let keys (a : 'a t) : key list =
List.fold_left
(fun acc (k, v) ->
if List.mem k acc then acc else k :: acc)
[] a
end
module type SAssoc = sig
type key
type 'a t
val empty : 'a t
val put : key -> 'a -> 'a t -> 'a t
val get : key -> 'a t -> 'a option
val keys : 'a t -> key list
end
module AssocTreePb : SAssoc = struct
type key = string
type 'a t = Vide | Noeud of (string * 'a * 'a t * 'a t)
let empty = Vide
let rec put k v a =
match a with
| Vide -> Noeud (k, v, Vide, Vide)
| Noeud (k', v', fg, fd) ->
if k = k' then Noeud (k, v, fg, fd)
else if k < k' then Noeud (k', v', put k v fg, fd)
else Noeud (k', v', fg, put k v fd)
let rec get k a =
match a with
| Vide -> None
| Noeud (k', v', fg, fd) ->
if k = k' then Some v'
else if k < k' then get k fg
else get k fd
let rec keys =
let rec aux a ks =
match a with
| Vide -> ks
| Noeud (k, _, fg, fd) -> k :: aux fg (aux fd ks)
in
fun a -> aux a []
end
let a = AssocTreePb.put "toto" 3 AssocTreePb.empty
module AssocTree : SAssoc with type key = string = struct
type key = string
type 'a t = Vide | Noeud of (string * 'a * 'a t * 'a t)
let empty = Vide
let rec put k v a =
match a with
| Vide -> Noeud (k, v, Vide, Vide)
| Noeud (k', v', fg, fd) ->
if k = k' then Noeud (k, v, fg, fd)
else if k < k' then Noeud (k', v', put k v fg, fd)
else Noeud (k', v', fg, put k v fd)
let rec get k a =
match a with
| Vide -> None
| Noeud (k', v', fg, fd) ->
if k = k' then Some v'
else if k < k' then get k fg
else get k fd
let rec keys =
let rec aux a ks =
match a with
| Vide -> ks
| Noeud (k, _, fg, fd) -> k :: aux fg (aux fd ks)
in
fun a -> aux a []
end
module Assoc : SAssoc with type key = string = AssocList
module Factures = struct
type facture = (int * float) Assoc.t
let ajoute (article : string) (quantite : int) (prix : float)
(f : facture) : facture =
match Assoc.get article f with
| None -> Assoc.put article (quantite, prix) f
| Some (q', _) -> Assoc.put article (quantite + q', prix) f
let string_of_item fact article =
match Assoc.get article fact with
| None -> ""
| Some (qte, px) ->
article ^ "(" ^ string_of_int qte ^ "): "
^ string_of_float px ^ "€"
let string_of_facture (f : facture) : string =
Assoc.keys f
|> List.map (string_of_item f)
|> List.fold_left (fun acc s -> acc ^ "\n" ^ s) ""
end
module Factures (Assoc : SAssoc with type key = string) = struct
type facture = (int * float) Assoc.t
let ajoute (article : string) (quantite : int) (prix : float)
(f : facture) : facture =
match Assoc.get article f with
| None -> Assoc.put article (quantite, prix) f
| Some (q', _) -> Assoc.put article (quantite + q', prix) f
let string_of_item fact article =
match Assoc.get article fact with
| None -> ""
| Some (qte, px) ->
article ^ "(" ^ string_of_int qte ^ "): "
^ string_of_float px ^ "€"
let string_of_facture (f : facture) : string =
Assoc.keys f
|> List.map (string_of_item f)
|> List.fold_left (fun acc s -> acc ^ "\n" ^ s) ""
end
module FacturesTree = Factures (AssocTree)
let _ =
FacturesTree.string_of_facture
(FacturesTree.ajoute "trombones" 100 0.01 AssocTree.empty)