(**************************************************************) (* Chapitre 7 de Programmation fonctionnelle, générique et objet (Une introduction avec le langage OCaml) Ph. Narbel, Vuibert, 2005 Ces programmes ont pour but d'illustrer les sujets traités dans le livre. Il n'est donné aucune garantie quant à leur utilisation dans le cadre d'une activité professionnelle ou commerciale. Ces programmes peuvent être copiés sous reserve que leur provenance soit citée et que cet avertissement soit inclus. These programs are provided without warranty of any kind. Their purpose is just to serve as illustrations in the book. Permission to copy is granted provided that citation and this disclaimer of warranty are included. *) let rec list_insert x l = match l with | [] -> [x] | y :: ys -> if x = y then l else if x < x then x :: l else y :: (list_insert x ys);; let list_insert' x l = let rec aux l = match l with | [] -> [x] | y :: ys -> if x = y then failwith "Already in" else if x < y then x :: l else y :: (aux ys) in try aux l with Failure "Already in" -> l;; open Graphics;; let my_draw_rect x0 y0 width height = let x1 = x0 + width and y1 = y0 + height in moveto x0 y0; lineto x0 y1; lineto x1 y1; lineto x1 y0; lineto x0 y0;; let rec rectangle_bouquet n size = if n <= 0 then flush_all () else ( my_draw_rect (Random.int size) (Random.int size) (Random.int size) (Random.int size); rectangle_bouquet (n - 1) size );; let full_analyze line = let tokens = Str.split (Str.regexp_string " :: ") line in let bool_in_ind x = match x with | "With" -> true | "Without" -> false | _ -> failwith "Bad Format in Script" in match tokens with | [action; length; x; key] -> (action, int_of_string length, bool_in_ind x, key) | _ -> failwith "Bad Format in Script";; let draw_path (start_x, start_y) script_name = let script = open_in script_name in let rec aux () = let (action, length, _, _) = full_analyze (input_line script) in match action with | "GoNorth" -> rlineto 0 length; aux (); | "GoSouth" -> rlineto 0 (-length); aux (); | "GoWest" -> rlineto (-length) 0; aux (); | "GoEast" -> rlineto length 0; aux (); | _ -> failwith "Bad Move in Script" in moveto start_x start_y; try aux () with End_of_file -> close_in script;; let array_map f arr = let len = Array.length arr in let new_arr = Array.make len (f arr.(0)) in let rec aux i = if i >= len then () else (new_arr.(i) <- f (arr.(i)); aux (i+1)) in aux 1; new_arr;; let array_map' f arr = let len = Array.length arr in let new_arr = Array.make len (f arr.(0)) in for i = 1 to len - 1 do new_arr.(i) <- f arr.(i) done; new_arr;; let iterator l = let cursor = ref l in fun () -> match !cursor with | [] -> failwith "End" | x :: xs -> cursor := xs; x;; type 'a dlist = | Empty | Cons of 'a ref * 'a dlist;; let rec dlist_map f l = match l with | Empty -> () | Cons (x, xs) -> x := f !x ; (dlist_map f xs);; let rec dlist_of_list l = match l with | [] -> Empty | x :: xs -> Cons (ref x, dlist_of_list xs);; let rec list_of_dlist l = match l with | Empty -> [] | Cons (x, xs) -> !x :: list_of_dlist (xs);; let rec dlist_map f l = match l with | Empty -> () | Cons (x, xs) -> x := f !x ; (dlist_map f xs);; type 'a rlist = | Empty | Cons of 'a * 'a rlist ref;; let rec rlist_of_list l = match l with | [] -> Empty | x :: xs -> Cons (x, ref (rlist_of_list xs));; let rec list_of_rlist l = match l with | Empty -> [] | Cons (x, xs) -> x :: (list_of_rlist (!xs));; let rlist_append l1 l2 = match l1 with | Empty -> l2 | Cons (_, y) -> let r = ref y in while (!(!r) != Empty) do let Cons (x, z) = !(!r) in r := z done; !r := l2; l1;;