Correction du TP5 Caml

correction_tp5.ml

type 'a bundle = 
  | Empty
  | Item of 'a * 'a bundle
;;

let empty_bundle () = Empty ;;

let cons bundle element = Item (element, bundle);;

let tail = function
  | Empty -> failwith "Tail failed: empty bundle"
  | Item (_, s) -> s ;;

let head = function
  | Empty -> failwith "Head failed: empty bundle"
  | Item (e, _) -> e ;;

let is_empty = function
  | Empty -> true
  | _ -> false ;;

type boolean =
  | True | False
  | Var of string
  | Not of boolean
  | And of boolean * boolean
  | Or of boolean * boolean
;;

(* quick fix *)
let append = (@) ;;

(* quick fix *)
let sort liste = List.stable_sort (function (a,b) -> function (c,d) -> if a = c then 0 else if a > c then 1 else -1) liste;;


let generate vars =
  let rec iter acc = function
    | [] -> [sort acc]
    | e::l -> append (iter ((e,True)::acc) l) (iter ((e,False)::acc) l)
  in iter [] vars;;


let rec value var = function
  | [] -> failwith ("Unbound Var: " ^ var)
  | (a,b)::_ when a = var -> b
  | _::l -> value var l 
;;

let rec eval expr varlist = match expr with
  | Var v -> value v varlist
  | Not e -> if (eval e varlist = True) then True else False
  | And (e1,e2) -> if (eval e1 varlist = True) then if (eval e2 varlist = True) then True else  False else False
  | Or (e1,e2)  ->  if (eval e1 varlist = True) then True else if (eval e2 varlist = True) then True else  False
  | x -> x
;;

let extract expr = 
  let rec contains x = function
    | [] -> false
    | e::_ when x = e -> true
    | _::l -> contains x l
  in
  let rec iter acc = function
    | [] -> acc
    | e::l when not (contains e acc) -> iter (e::acc) l
    | _::l -> iter acc l
  in
  let rec ext = function
    | Var v -> [v]
    | Not e -> ext e
    | And (e1,e2) | Or (e1,e2) -> append (ext e1) (ext e2)
    | _ -> []
  in 
    iter [] (ext expr)
;;

let evaluate expr =
  let values = generate (extract expr)
  in 
  let rec iter = function
    | [] -> []
    | e::l -> (e, eval expr e) :: (iter l)
  in
  iter values;;

let soc a = String.make 1 a;;
let var a = (a >= 'a' && a <= 'z') ;;
let priority = function
  | '!' -> 3
  | '&' -> 2
  | '|' -> 1
  |   _ -> 0 ;;

let parse s =
  let l = String.length s in
  let rec iter out op = function
    | i when i = l -> if (is_empty op) then out else iter (cons out (head op)) (tail op) i 
    | i when var s.[i] -> iter (cons out (s.[i])) op (i+1)
    | i -> if not (is_empty op) && ((priority (head op)) > (priority s.[i])) then
 	      iter (cons out (head op)) (tail op) (i)
           else
 	      iter out (cons op s.[i]) (i+1)
  in iter Empty Empty 0 ;;

parse "a&b" ;;

let builder stack =
  let rec iter stack =
    if (is_empty stack) then failwith "Build failed: instructions uncleared"
    else
      let a = (head stack) and stack = (tail stack) in
      if var a then (Var (soc a),stack)
      else
	let (eval1,stack) = (iter stack) in
	if (a = '!') then (Not (eval1), stack)
	else
	  let (eval2,stack) = (iter stack) in
	  match a with
	  | '&' -> (And (eval1,eval2),stack)
	  | '|' -> (Or (eval1,eval2),stack)
	  | _ -> failwith "Build failed: unknown operator"
  in let a,b = iter stack in a;;

evaluate (builder (parse "!a|!b&!c|!b"));;
evaluate (Or (Var "a", Var "b"));;
evaluate (builder (parse "a|b"));;
evaluate (Or (And (Var "a", Var "b"), And (Var "c", Var "d")));;
evaluate (builder (parse "a&b|c&d"));;



let display expr =
  let rec header = function
    | []       -> print_newline ()
    | (a,_)::l -> print_string (" " ^ a); header l
  and
      row = function
      | []           -> ()
      | (_,True)::l  -> print_string " T"; row l
      | (_,False)::l -> print_string " F"; row l
      | _ -> failwith "Display failed: type error"
  in
  let rec iter = function
    | [] -> ()
    | (v,True) :: l  -> row v; print_endline "   T"; iter l
    | (v,False) :: l -> row v; print_endline "   F"; iter l
    | _ -> failwith "Display failed: type error"
  in match expr with
  | [] -> ()
  | (e,_)::_ -> header e; iter expr;;


display (boolean_of_string "a|b|c|d|e|f|g|h");;

;;
truth_table  ;;