test: add the Hoepman ring orientation algo

(not yet finished: the legitimate predicate is not rigth)

test/ring-orientation/p.ml

+(* Time-stamp: <modified the 07/07/2023 (at 15:24) by Erwan Jahier> *)
+
+(* Uniform deterministic self-stabilizing ring-orientation on odd-length rings
+  Hoepman, Jaap-Henk
+  WDAG'1994
+
+  hyp: central daemon
+ *)
+
+open Algo
+open State
+
+let (init_state: int -> string -> 'st) =
+  fun _nl _ ->
+  { color_0 = Random.bool () ; phase_pos = Random.bool () ; orient_left =  Random.bool () }
+
+let (enable_f: 'st -> 'st neighbor list -> action list) =
+  fun q nl ->
+  assert (card() mod 2 = 1); (* Odd rings only *)
+    match List.map state nl with
+    |  [p; r]  -> (match p,q,r with
+        | { color_0 = true  ; _ }, { color_0 = true  ; _ },                    { color_0 = true  ; _ } -> ["a"]
+        | { color_0 = true  ; _ }, { color_0 = false ; phase_pos = true ; _ }, { color_0 = true  ; _ } -> ["b"]
+        | { color_0 = false ; _ }, { color_0 = false ; _ },                    { color_0 = false ; _ } -> ["c"]
+        | { color_0 = false ; _ }, { color_0 = true  ; phase_pos = true; _  }, { color_0 = false ; _ } -> ["d"]
+
+        | { color_0 = true  ; phase_pos = true ; _ },
+          { color_0 = true  ; phase_pos = false ; _ },
+          { color_0 = false ; phase_pos = false ; _ }  -> ["e_pr"]
+
+        | { color_0 = false ; phase_pos = false ; _ },
+          { color_0 = true  ; phase_pos = false ; _ },
+          { color_0 = true  ; phase_pos = true ; _ } -> ["e_rp"]
+
+        | { color_0 = false ; phase_pos = true ; _ },
+          { color_0 = false ; phase_pos = false ; _ },
+          { color_0 = true  ; phase_pos = false ; _ } -> ["f_pr"]
+
+        | { color_0 = true  ; phase_pos = false ; _ },
+          { color_0 = false ; phase_pos = false ; _ },
+           { color_0 = false ; phase_pos = true ; _ } -> ["f_rp"]
+
+        | { color_0 = true  ; phase_pos = false ; _ },
+          { color_0 = true  ; phase_pos = false ; _ },
+          { color_0 = false ;  _ }
+        | { color_0 = false ;  _ },
+          { color_0 = true  ; phase_pos = false ; _ },
+          { color_0 = true  ; phase_pos = false ; _ } -> ["g"]
+
+        | { color_0 = true  ; phase_pos = true ; _ },
+          { color_0 = true  ; phase_pos = true ; _ },
+          { color_0 = false ;  _ }
+        | { color_0 = false ;  _ },
+          { color_0 = true  ; phase_pos = true ; _ },
+          { color_0 = true  ; phase_pos = true ; _ } -> ["h"]
+
+        | { color_0 = false  ; phase_pos = false ; _ },
+          { color_0 = false  ; phase_pos = false ; _ },
+          { color_0 = true ; _ }
+        | { color_0 = true ; _ },
+          { color_0 = false  ; phase_pos = false ; _ },
+          { color_0 = false  ; phase_pos = false ; _ } -> ["i"]
+
+        | { color_0 = false  ; phase_pos = true ; _ },
+          { color_0 = false  ; phase_pos = true ; _ },
+          { color_0 = true ; _ }
+        | { color_0 = true ; _ },
+          { color_0 = false  ; phase_pos = true ; _ },
+          { color_0 = false  ; phase_pos = true ; _ } -> ["j"]
+
+        | _ -> []
+      )
+    | _ -> failwith "only works on rings"
+
+(*        | { color_0 = cp ; phase_pos = pp ; _ },
+          { color_0 = cq ; phase_pos = pq ; _ },
+          { color_0 = cr ; phase_pos = pr ; _ } ->
+           let c2s c = if c then "0" else "1" in
+          let p2s c = if c then "+" else "-" in
+          failwith (Printf.sprintf "Missing case: %s%s %s%s %s%s "
+                      (c2s cp) (p2s pp) (c2s cq) (p2s pq) (c2s cr) (p2s pr) )
+
+ *)
+
+let orientation = function
+  | [  { phase_pos = true ; _} ; { phase_pos = false; _ }  ] -> true
+  | [  { phase_pos = false ; _} ; { phase_pos = true ; _ } ] -> false
+  | [  { phase_pos = true ; _} ; { phase_pos = true; _ } ] -> assert false
+  | [  { phase_pos = false ; _} ; { phase_pos = false; _ } ] -> assert false
+  | _ -> assert false
+
+let (step_f : 'st -> 'st neighbor list -> action -> 'st ) =
+  fun e nl ->
+  function
+  | "a" -> { e with color_0 = false ; phase_pos = false }
+  | "b" -> { e with color_0 = false ; phase_pos = false }
+  | "c" -> { e with color_0 = true ; phase_pos = false }
+  | "d" -> { e with color_0 = true ; phase_pos = false }
+
+  | "e_pr" -> { color_0 = false ; phase_pos = true ; orient_left = orientation (List.map state nl) }
+  | "e_rp" -> { color_0 = false ; phase_pos = true ; orient_left = orientation (List.map state nl |> List.rev) }
+  | "f_pr" -> { color_0 = true ; phase_pos = true  ; orient_left = orientation (List.map state nl) }
+  | "f_rp" -> { color_0 = true ; phase_pos = true  ; orient_left = orientation (List.map state nl |> List.rev) }
+
+  | "g" -> { e with color_0 = true ; phase_pos = true }
+  | "h" -> { e with color_0 = true ; phase_pos = false }
+  | "i" -> { e with color_0 = false ; phase_pos = true }
+  | "j" -> { e with color_0 = false ; phase_pos = false }
+  | _ -> e

test/ring-orientation/some_session

+n
+n
+n
+n
+wait 3
+print_event !e;;
+

test/ring-orientation/state.ml

+(* Time-stamp: <modified the 29/06/2023 (at 16:45) by Erwan Jahier> *)
+
+type t = { color_0 : bool ; phase_pos : bool ; orient_left : bool }
+
+let to_string s =
+  Printf.sprintf "color_0=%b phase_pos=%b orient_left=%b" s.color_0 s.phase_pos s.orient_left
+
+let (of_string: (string -> t) option) =
+  Some (fun s ->
+      Scanf.sscanf s "color_0=%B phase_pos=%B orient_left=%B"
+        (fun color_0 phase_pos orient_left -> { color_0 ; phase_pos ; orient_left  }))
+
+let copy x = x
+
+let actions = ["a";"b";"c";"d";"e_pr";"e_rp";"f_pr";"f_rp";"g";"h";"i";"j"]