Library ref_alternatives

Require Import base.
Require Import prelim.

Section ref_alt. Context {Obs:ObservationSystem}.

Record ELTS :=
  { state : Type
  ; steps : state -> O -> lift state -> Prop
  }.

Inductive order_options := XY | YX.
Definition swap_order z :=
  match z with
  | XY => YX
  | YX => XY
  end.

Record ref_choices := RefC { side_order : order_options; Xpos : bool ; Ypos : bool }.

Definition swap_choices (RC:ref_choices) :=
  RefC (swap_order (side_order RC)) (Ypos RC) (Xpos RC).

Definition swap_choices_inv RC : swap_choices (swap_choices RC) = RC.

Definition forcesX RC :=
  match side_order RC with
  | XY => Xpos RC
  | YX => andb (Xpos RC) (Ypos RC)
  end.

Definition forcesY RC :=
  match side_order RC with
  | XY => andb (Xpos RC) (Ypos RC)
  | YX => Ypos RC
  end.

Definition strengthen (RC1 RC2:ref_choices) :=
  RefC (side_order RC1) (Xpos RC1)
                        (orb (Ypos RC1) (forcesY RC2)).

Definition strengthen' (RC1 RC2:ref_choices) :=
  RefC (side_order RC1) (orb (Xpos RC1) (forcesX RC2))
                        (Ypos RC1).

Definition unpack (b:bool) (A:ELTS) (a:lift (state A)) (k: state A -> Prop) :=
  match b with
  | true => exists a_, contains a a_ /\ k a_
  | false => forall a_, contains a a_ -> k a_
  end.

Definition refinement (RC:ref_choices) (X Y:ELTS) (R:state X -> state Y -> Prop) :=
  forall x y, R x y ->
    forall o x', steps X x o x' -> exists y', steps Y y o y' /\
      match side_order RC with
      | XY => unpack (Xpos RC) X x' (fun x_ => unpack (Ypos RC) Y y' (fun y_ => R x_ y_))
      | YX => unpack (Ypos RC) Y y' (fun y_ => unpack (Xpos RC) X x' (fun x_ => R x_ y_))
      end.

Definition refines RC1 RC2 X Y x y :=
  exists R,
    refinement RC1 X Y R /\
    refinement (swap_choices RC2) Y X (inv R) /\
    R x y.

Definition refinement_strengthen RC1 RC2 X Y R :
  refinement RC1 X Y R ->
  refinement (swap_choices RC2) Y X (inv R) ->
  refinement (strengthen RC1 RC2) X Y R.

Definition refinement_strengthen' RC1 RC2 X Y R :
  refinement RC1 X Y R ->
  refinement (swap_choices RC2) Y X (inv R) ->
  refinement (swap_choices (strengthen' RC2 RC1)) Y X (inv R).

Lemma refines_strengthen RC1 RC2 X Y x y :
  refines RC1 RC2 X Y x y ->
  refines (strengthen RC1 RC2) (strengthen' RC2 RC1) X Y x y.

Lemma refines_symmetric RC1 RC2 X Y x y :
  refines RC1 RC2 X Y x y ->
  refines (swap_choices RC2) (swap_choices RC1) Y X y x.

Require Import List.

Definition both {A} (f:bool -> list A) : list A :=
  f true ++ f false.

Definition ord_both {A} (f:order_options -> list A) : list A :=
  f XY ++ f YX.

Definition make (o1:order_options) (x1 y1:bool) (o2:order_options) (x2 y2:bool) : list (ref_choices * ref_choices) :=
  (RefC o1 x1 y1, RefC o2 x2 y2) :: nil.

Definition enumerate := (ord_both (fun a => both (fun b => both (fun c => ord_both (fun d => both (fun e => both (make a b c d e))))))).

Fixpoint keep_uniq {A} (keep:A -> list A -> bool) (l1 l2:list A) : list A :=
  match l2 with
  | nil => l1
  | x::l2' => keep_uniq keep (if keep x l1 then x::l1 else l1) l2'
  end.

Definition normalize RC :=
  if andb (Xpos RC) (Ypos RC) then RefC XY true true else
  if orb (Xpos RC) (Ypos RC) then RC else RefC XY false false.

Definition asdf : forall (x y:ref_choices * ref_choices), {x = y}+{x<>y}.

Definition asdf' : forall (x y:ref_choices), {x=y}+{x<>y}.

Definition expected :=
    (RefC XY true true, RefC XY true true) ::
    (RefC YX false true, RefC YX false true) ::
    (RefC XY false true, RefC XY false true) ::
    (RefC XY false true, RefC YX true false) ::
    (RefC XY false false, RefC XY false false) :: nil.
Definition reflx RC :=
  match side_order RC with
  | XY => negb (Xpos RC)
  | YX => negb (Ypos RC)
  end.

Definition is_interesting (x:ref_choices * ref_choices) l :=
  let (RC1,RC2) := x in
  let RC1' := normalize (strengthen RC1 RC2) in
  let RC2' := normalize (strengthen' RC2 RC1) in
    if (In_dec asdf (RC1', RC2') (l++expected)) then false else
    if (In_dec asdf (swap_choices RC2', swap_choices RC1') (l++expected)) then false else true.

Definition interesting := keep_uniq is_interesting nil enumerate.
Eval vm_compute in length interesting.

End ref_alt.