(** A library of Bellantoni-Cook functions on bitstrings without numerical interpretation *)
(** * Swapping of two arguments  - arities: (2, 0) *)
Definition inv_e (e : BC) : BC :=
comp 2 0 e (proj 2 0 1 :: proj 2 0 0 :: nil) nil.
(** * Conversion from arities (1, 1) to (2, 0) *)
Definition from_11_to_20 (e : BC) : BC :=
comp 2 0 e (proj 2 0 0 :: nil) (proj 2 0 1 :: nil).
(** * Concatenation of bitstrings  - arities: (1, 1) *)
Definition app_e : BC :=
rec (proj 0 1 0)
(comp 1 2 (succ false) nil ((proj 1 2 1) :: nil))
(comp 1 2 (succ true) nil ((proj 1 2 1) :: nil)).
(** * constant function *)
Program Fixpoint constant (v:bs) : { e : BC | arities e = ok_arities 0 0 /\ sem e nil nil = v } :=
match v with
| nil => BC.zero
| b :: v' => BC.comp 0 0 (BC.succ b) nil [constant v']
end.
Next Obligation.
simpl.
tauto.
Qed.
Next Obligation.
simpl.
intros bs_to_BC v b v' Hv.
subst v.
destruct (bs_to_BC v') as [e [H1 H2] ].
simpl.
rewrite H1, H2.
tauto.
Defined.
(** * Recursion on the length of a bitstring, i.e., ignoring the value 0 or 1 of bits *)
Definition rec2 g h := rec g h h.
Definition cond2_correct n s x g h0 h1 vnl vsl :
length vnl = n ->
length vsl = s ->
sem (cond2 n s x g h0 h1) vnl vsl =
match sem x vnl vsl with
| nil => sem g vnl vsl
| true  :: _ => sem h0 vnl (tl (sem x vnl vsl) :: vsl)
| false :: _ => sem h1 vnl (tl (sem x vnl vsl) :: vsl)
end.
(** * Recursion with one function [h] taking [i] instead of two function [h]_[i] *)
Definition rec1 n s g h :=
rec
g
(comp (S n) (S s) h
(comp (S n) 0 (succ false) nil [proj (S n) 0 0] ::
map (proj (S n) 0)     (seq 1     n))
(map (proj (S n) (S s)) (seq (S n) (S s))))
(comp (S n) (S s) h
(comp (S n) 0 (succ true) nil [proj (S n) 0 0] ::
map (proj (S n) 0)     (seq 1     n))
(map (proj (S n) (S s)) (seq (S n) (S s)))).
Fixpoint sem_rec1
(g h:BC)(v : bs)(vnl vsl : list bs) {struct v} :=
match v with
| nil => sem g vnl vsl
| _::v' => sem h (v::vnl) (sem_rec1 g h v' vnl vsl :: vsl)
end.
(** * Recursion on the result of the function [x], with one function [h] taking [i] instead of two function [h]_[i] *)
Definition rec3 n s x g h : BC :=
comp n s
(rec1 n s g h)
(x ::
map (proj n 0) (seq 0 n))
(map (proj n s) (seq n s)).
(** * True  - with any arities (n, s) *)
Definition true_e (n s:nat) : BC :=
comp n s (comp 0 0 (succ true) nil (zero :: nil)) nil nil.
(** * False  - with any arities (n, s) *)
Definition false_e (n s:nat) : BC :=
comp n s (comp 0 0 (succ false) nil (zero :: nil)) nil nil.
(** * Parity  - arities: (0, 1) *)
Definition parity_e : BC := (* 0 1 *)
comp 0 1 cond nil [proj 0 1 0; false_e 0 1; true_e 0 1; false_e 0 1].
(** * Functions P, P', Y and I as defined by Bellantoni and Cook  - arities of P: (1, 1)  - arities of P': (2, 0)  - arities of Y: (2, 1)  - arities of I: (2, 1) *)
Definition P (x:bs)(y:bs) : bs := skipn (length x) y.
Definition P_e : BC :=
rec (proj 0 1 0)
(comp 1 2 pred nil [proj 1 2 1])
(comp 1 2 pred nil [proj 1 2 1]).
Global Opaque P_e.
Definition P'_e := from_11_to_20 P_e.
Definition Y (z w y:bs) : bs :=
P (P z w) y.
Definition Y_e : BC :=
comp 2 1 P_e
[comp 2 0 P'_e [proj 2 0 0; proj 2 0 1] nil]
[proj 2 1 2].

Lemma Y_correct z w y :
sem Y_e [z;w] [y] = Y z w y.