(* * Machines for shifting [positive] binary numbers *)
Local Open Scope positive_scope.
(* *** Machine for Shifting Left *)
Definition ShiftLeft_Rel (bit : bool) : pRel sigPos^+ unit 1 :=
fun tin '(yout, tout) =>
forall (p : positive),
tin[@Fin0] ≃ p ->
tout[@Fin0] ≃ p ~~ bit.
Definition ShiftLeft (bit : bool) : pTM sigPos^+ unit 1 :=
GoToLSB_start;;
Shift_L (@isStart _) (bitToSigPos' bit);;
Move Lmove;;
Write (inl START).
(* *** Machine for shifting a number [y] [pos_size x]-times left. *)
Definition ShiftLeft_num_Step_Rel : pRel sigPos^+ (option unit) 2 :=
fun tin '(yout, tout) =>
(forall (px : positive) (bx : bool) (bitsx : list bool) (y : positive),
atBit tin[@Fin0] px bx bitsx ->
tin[@Fin1] ≃ y ->
movedToLeft tout[@Fin0] px bx bitsx /\
tout[@Fin1] ≃ y~0 /\
yout = None) /\
(forall (px : positive) (y : positive),
atHSB tin[@Fin0] px ->
tin[@Fin1] ≃ y ->
tout = tin /\
yout = Some tt).
Definition ShiftLeft_num_Step : pTM sigPos^+ (option unit) 2 :=
Switch (ReadPosSym@[|Fin0|])
(fun (s : option bool) =>
match s with
| Some b  => Return (SetBitAndMoveLeft b @[|Fin0|];; ShiftLeft false @[|Fin1|]) None
| None => Return Nop (Some tt)
end).
Definition ShiftLeft_num_Loop_Rel : pRel sigPos^+ unit 2 :=
fun tin '(yout, tout) =>
(forall (px : positive) (bx : bool) (bitsx : list bool) (y : positive),
atBit tin[@Fin0] px bx bitsx ->
tin[@Fin1] ≃ y ->
atHSB tout[@Fin0] (append_bits px (bx::bitsx)) /\
tout[@Fin1] ≃ shift_left y (pos_size (px~~bx))) /\
(forall (px : positive) (y : positive),
atHSB tin[@Fin0] px ->
tin[@Fin1] ≃ y ->
tout = tin).
Definition ShiftLeft_num_Loop := While ShiftLeft_num_Step.
Definition ShiftLeft_num : pTM sigPos^+ unit 2 := GoToLSB_start@[|Fin0|];; ShiftLeft_num_Loop;; (Move Lmove)@[|Fin0|].
Definition ShiftLeft_num_Rel : pRel sigPos^+ unit 2 :=
fun tin '(yout, tout) =>
forall (p0 : positive) (p1 : positive),
tin[@Fin0] ≃ p0 ->
tin[@Fin1] ≃ p1 ->
tout[@Fin0] ≃ p0 /\
tout[@Fin1] ≃ shift_left p1 (pos_size p0).

Lemma ShiftLeft_num_Realise : ShiftLeft_num ⊨ ShiftLeft_num_Rel.