formal_lp/hypermap/tests/test_all_lists.hl

   1 needs "../formal_lp/hypermap/tests/Tri2.ml";;
   2 needs "../formal_lp/hypermap/tests/Quad2.ml";;
   3 needs "../formal_lp/hypermap/tests/Pent2.ml";;
   4 needs "../formal_lp/hypermap/tests/Hex2.ml";;
   5
   6 (* 18762 *)
   7 length pent + length hex + length tri + length quad;;
   8
   9
  10
  11 open List;;
  12
  13 (* undup *)
  14 let rec undup s =
  15   match s with
  16       [] -> []
  17     | h :: t -> if mem h t then undup t else h :: undup t;;
  18
  19
  20 (* uniq *)
  21 let rec uniq_test s =
  22   match s with
  23       [] -> true
  24     | h :: t -> if mem h t then false else uniq_test t;;
  25
  26
  27 (* list_of_elements *)
  28 let list_of_elements hyp = undup (flatten hyp);;
  29
  30
  31 (* list_pairs *)
  32 let list_pairs s =
  33   let head = hd s in
  34   let rec list_pairs_head s =
  35     match s with
  36         [] -> failwith "list_pairs"
  37       | [h] -> [h,head]
  38       | h1 :: h2 :: t -> (h1,h2) :: list_pairs_head (h2 :: t) in
  39     list_pairs_head s;;
  40
  41
  42 (* list_of_faces *)
  43 let list_of_faces hyp =
  44   map list_pairs hyp;;
  45
  46
  47 (* list_of_darts *)
  48 let list_of_darts hyp = flatten (list_of_faces hyp);;
  49
  50
  51 (* find_pair_list *)
  52 let rec find_pair_list hyp d =
  53   match hyp with
  54       [] -> []
  55     | f :: t -> if mem d (list_pairs f) then f else find_pair_list t d;;
  56
  57
  58 (* find_face *)
  59 let find_face hyp d = list_pairs (find_pair_list hyp d);;
  60
  61
  62 (* next_el *)
  63 let next_el s d =
  64   let head = hd s in
  65   let rec next s =
  66     match s with
  67         [] -> failwith "next_el"
  68       | [h] -> if Pervasives.compare h d = 0 then head else next []
  69       | h1 :: h2 :: t -> if Pervasives.compare h1 d = 0 then h2 else next (h2 :: t) in
  70     next s;;
  71
  72
  73 (* prev_el *)
  74 let prev_el s d =
  75   let rec prev_rec prev s =
  76     match s with
  77         [] -> failwith "prev_el"
  78       | h :: t -> if Pervasives.compare h d = 0 then prev else prev_rec h t in
  79     prev_rec (last s) s;;
  80
  81
  82 (* e_list *)
  83 let e_list (d1,d2) = d2,d1;;
  84
  85
  86 (* f_list *)
  87 let f_list hyp d = next_el (find_face hyp d) d;;
  88
  89
  90 (* n_list *)
  91 let n_list hyp d = e_list (prev_el (find_face hyp d) d);;
  92
  93
  94 (* orbit *)
  95 let orbit f d =
  96   let rec orbit_acc acc x =
  97     let next = f x in
  98       if mem next acc then acc else orbit_acc (next :: acc) next in
  99     rev (orbit_acc [d] d);;
 100
 101
 102 (* orbits *)
 103 let orbits f set =
 104   let rec orbits_rec set =
 105     match set with
 106         [] -> []
 107       | h :: t ->
 108           let x = orbit f h in
 109             x :: orbits_rec (subtract set x) in
 110     orbits_rec set;;
 111
 112
 113 (* good_list *)
 114 let good_list hyp =
 115   let darts = list_of_darts hyp in
 116   let c1 = uniq_test darts in
 117   let c2 = for_all (fun l -> l <> []) hyp in
 118   let c3 = for_all (fun (d1,d2) -> mem (d2,d1) darts) darts in
 119     c1 & c2 & c3;;
 120
 121
 122 (* good_list_nodes *)
 123 let good_list_nodes hyp =
 124   let darts = list_of_darts hyp in
 125   let n0 = length (list_of_elements hyp) in
 126   let n1 = length (orbits (n_list hyp) darts) in
 127     n0 = n1;;
 128
 129
 130
 131 let tm = hd hex;;
 132 good_list tm;;
 133 good_list_nodes tm;;
 134
 135 let good_test = fold_left (fun l h -> l & good_list h) true;;
 136 let good_nodes_test = fold_left (fun l h -> l & good_list_nodes h) true;;
 137
 138 let tri_test = good_test tri;;
 139 let quad_test = good_test quad;;
 140 let pent_test = good_test pent;;
 141 let hex_test = good_test hex;;
 142
 143
 144 let tri_test2 = good_nodes_test tri;;
 145 let quad_test2 = good_nodes_test quad;;
 146 let pent_test2 = good_nodes_test pent;;
 147 let hex_test2 = good_nodes_test hex;;