Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.ListUtil.FoldBool.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.OptionList.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Bool.Reflect.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Import ListNotations. Local Open Scope bool_scope. Local Open Scope Z_scope.

Module Compilers.
  Export Language.Compilers.
  Export Language.API.Compilers.

  Module ZRange.
    Module type.
      Local Notation binterp := base.interp.
      Local Notation tinterp_gen := type.interp.
      Local Notation einterp := (type.interp base.interp).
      Module base.
        (** turn a [base.type] into a [Set] describing the type of
          bounds on that primitive; Z is a range, nat and bool are exact values *)
        Fixpoint interp (t : base.type) : Type
          := match t with
             | base.type.type_base base.type.Z => zrange
             | base.type.type_base _ as t
             | base.type.unit as t
               => base.interp t
             | base.type.prod A B => interp A * interp B
             | base.type.list A => list (interp A)
             | base.type.option A => option (interp A)
             end%type.
        Definition is_neg {t} : interp t -> bool
          := match t with
             | base.type.type_base base.type.Z => fun r => (lower r <? 0) && (upper r <=? 0)
             | _ => fun _ => false
             end.
        Fixpoint is_tighter_than {t} : interp t -> interp t -> bool
          := match t with
             | base.type.type_base base.type.Z => is_tighter_than_bool
             | base.type.type_base _ as t
             | base.type.unit as t
               => base.interp_beq (@base.base_interp_beq)
             | base.type.prod A B
               => fun '(a, b) '(a', b')
                  => @is_tighter_than A a a' && @is_tighter_than B b b'
             | base.type.list A
               => fold_andb_map (@is_tighter_than A)
             | base.type.option A
               => option_beq (@is_tighter_than A)
             end%bool.
        Fixpoint is_bounded_by {t} : interp t -> binterp t -> bool
          := match t with
             | base.type.type_base base.type.Z => fun r z => ZRange.is_bounded_by_bool z r
             | base.type.type_base _ as t
             | base.type.unit as t
               => base.interp_beq (@base.base_interp_beq)
             | base.type.prod A B
               => fun '(a, b) '(a', b')
                  => @is_bounded_by A a a' && @is_bounded_by B b b'
             | base.type.list A
               => fold_andb_map (@is_bounded_by A)
             | base.type.option A
               => option_beq_hetero (@is_bounded_by A)
             end.
        Fixpoint interp_beq {t} : interp t -> interp t -> bool
          := match t return interp t -> interp t -> bool with
             | base.type.type_base base.type.Z => zrange_beq
             | base.type.type_base _ as t
             | base.type.unit as t
               => base.interp_beq (@base.base_interp_beq)
             | base.type.prod A B
               => fun '(a, b) '(a', b')
                  => @interp_beq A a a' && @interp_beq B b b'
             | base.type.list A
               => list_beq _ (@interp_beq A)
             | base.type.option A
               => option_beq (@interp_beq A)
             end%bool.

        Global Instance reflect_interp_eq {t} : reflect_rel (@eq _) (@interp_beq t).
        Proof.
          induction t; cbn [interp_beq]; intros; break_innermost_match; try exact _.
        Defined.

        Lemma interp_beq_bl {t x y} : @interp_beq t x y = true -> x = y.
        Proof. apply reflect_to_beq; exact _. Qed.
        Lemma interp_beq_lb {t x y} : x = y -> @interp_beq t x y = true.
        Proof. apply reflect_to_beq; exact _. Qed.

        Module option.
          (** turn a [base.type] into a [Set] describing the type
              of optional bounds on that primitive; bounds on a [Z]
              may be either a range, or [None], generally indicating
              that the [Z] is unbounded. *)
          Fixpoint interp (t : base.type) : Type
            := match t with
               | base.type.type_base _ as t
                 => option (base.interp t)
               | base.type.prod A B => interp A * interp B
               | base.type.list A => option (list (interp A))
               | base.type.option A => option (option (interp A))
               | base.type.unit => unit
               end%type.
          Fixpoint None {t} : interp t
            := match t with
               | base.type.unit => tt
               | base.type.list _
               | base.type.option _
               | base.type.type_base _
                 => Datatypes.None
               | base.type.prod A B
                 => (@None A, @None B)
               end.
          Fixpoint Some {t} : base.interp t -> interp t
            := match t with
               | base.type.unit
                 => fun _ => tt
               | base.type.type_base _
                 => Datatypes.Some
               | base.type.list A
                 => fun ls => Datatypes.Some (List.map (@Some A) ls)
               | base.type.option A
                 => fun ls => Datatypes.Some (option_map (@Some A) ls)
               | base.type.prod A B
                 => fun '(a, b)
                    => (@Some A a, @Some B b)
               end.
          Fixpoint lift_Some {t} : interp t -> option (base.interp t)
            := match t with
               | base.type.type_base _
                 => fun x => x
               | base.type.unit
                 => fun x => Datatypes.Some tt
               | base.type.list A
                 => fun ls => ls <- ls; Option.List.lift (List.map (@lift_Some A) ls)
               | base.type.option A
                 => fun v => v <- v; Option.lift (option_map (@lift_Some A) v)
               | base.type.prod A B
                 => fun '(a, b) => a <- @lift_Some A a; b <- @lift_Some B b; Datatypes.Some (a, b)
               end%option.
          (** Keep data about list length and nat value, but not zrange *)
          Fixpoint strip_ranges {t} : interp t -> interp t
            := match t with
               | base.type.type_base base.type.Z => fun _ => Datatypes.None
               | base.type.type_base _
               | base.type.unit
                 => fun x => x
               | base.type.list A
                 => fun ls => ls <- ls; Datatypes.Some (List.map (@strip_ranges A) ls)
               | base.type.option A
                 => fun v => v <- v; Datatypes.Some (option_map (@strip_ranges A) v)
               | base.type.prod A B
                 => fun '(a, b)
                    => (@strip_ranges A a, @strip_ranges B b)
               end%option.
          Definition is_neg {t} : interp t -> bool
            := match t with
               | base.type.type_base base.type.Z
                 => fun v => match v with
                             | Datatypes.Some v => @is_neg (base.type.type_base base.type.Z) v
                             | Datatypes.None => false
                             end
               | t => fun _ => false
               end.
          Fixpoint is_tighter_than {t} : interp t -> interp t -> bool
            := match t with
               | base.type.type_base _ as t
                 => fun r1 r2
                    => match r1, r2 with
                       | _, Datatypes.None => true
                       | Datatypes.None, Datatypes.Some _ => false
                       | Datatypes.Some r1, Datatypes.Some r2 => base.is_tighter_than (t:=t) r1 r2
                       end
               | base.type.prod A B
                 => fun '(a, b) '(a', b')
                    => @is_tighter_than A a a' && @is_tighter_than B b b'
               | base.type.list A
                 => fun ls1 ls2
                    => match ls1, ls2 with
                       | Datatypes.None, Datatypes.None => true
                       | Datatypes.Some _, Datatypes.None => true
                       | Datatypes.None, Datatypes.Some _ => false
                       | Datatypes.Some ls1, Datatypes.Some ls2 => fold_andb_map (@is_tighter_than A) ls1 ls2
                       end
               | base.type.option A
                 => fun v1 v2
                    => match v1, v2 with
                       | Datatypes.None, Datatypes.None => true
                       | Datatypes.Some _, Datatypes.None => true
                       | Datatypes.None, Datatypes.Some _ => false
                       | Datatypes.Some v1, Datatypes.Some v2 => option_beq (@is_tighter_than A) v1 v2
                       end
               | base.type.unit => fun 'tt 'tt => true
               end.
          Fixpoint interp_beq {t} : interp t -> interp t -> bool
            := match t return interp t -> interp t -> bool with
               | base.type.type_base _ as t => option_beq base.interp_beq
               | base.type.prod A B
                 => fun '(a, b) '(a', b')
                    => @interp_beq A a a' && @interp_beq B b b'
               | base.type.list A
                 => option_beq (list_beq _ (@interp_beq A))
               | base.type.option A
                 => option_beq (option_beq (@interp_beq A))
               | base.type.unit => fun 'tt 'tt => true
               end.

          Global Instance reflect_interp_eq {t} : reflect_rel (@eq _) (@interp_beq t).
          Proof.
            induction t; cbn [interp_beq]; intros; break_innermost_match; try exact _.
          Defined.

          Lemma interp_beq_bl {t x y} : @interp_beq t x y = true -> x = y.
          Proof. apply reflect_to_beq; exact _. Qed.
          Lemma interp_beq_lb {t x y} : x = y -> @interp_beq t x y = true.
          Proof. apply reflect_to_beq; exact _. Qed.

          Fixpoint is_bounded_by {t} : interp t -> binterp t -> bool
            := match t with
               | base.type.type_base base.type.Z as t
               | base.type.type_base _ as t
                 => fun r
                    => match r with
                       | Datatypes.Some r => @base.is_bounded_by t r
                       | Datatypes.None => fun _ => true
                       end
               | base.type.prod A B
                 => fun '(a, b) '(a', b')
                    => @is_bounded_by A a a' && @is_bounded_by B b b'
               | base.type.list A
                 => fun ls1 ls2
                    => match ls1 with
                       | Datatypes.None => true
                       | Datatypes.Some ls1 => fold_andb_map (@is_bounded_by A) ls1 ls2
                       end
               | base.type.option A
                 => fun v1 v2
                    => match v1 with
                       | Datatypes.None => true
                       | Datatypes.Some v1 => option_beq_hetero (@is_bounded_by A) v1 v2
                       end
               | base.type.unit => fun 'tt _ => true
               end.

          Lemma is_bounded_by_Some {t} r val
            : is_bounded_by (@Some t r) val = base.is_bounded_by r val.
          Proof.
            induction t;
              repeat first [ reflexivity
                           | progress cbn in *
                           | progress destruct_head'_prod
                           | progress destruct_head' base.type.base
                           | progress destruct_head' option
                           | rewrite fold_andb_map_map1
                           | match goal with H : _ |- _ => rewrite H end
                           | match goal with H : _ |- _ => setoid_rewrite H end ].
          Qed.

          Lemma is_tighter_than_is_bounded_by {t} r1 r2 val
                (Htight : @is_tighter_than t r1 r2 = true)
                (Hbounds : is_bounded_by r1 val = true)
            : is_bounded_by r2 val = true.
          Proof.
            induction t;
              repeat first [ progress destruct_head'_prod
                           | progress destruct_head'_and
                           | progress destruct_head'_unit
                           | progress destruct_head' option
                           | progress cbn [interp binterp base.interp is_bounded_by is_tighter_than base.is_tighter_than base.is_bounded_by option_beq_hetero] in *
                           | progress subst
                           | reflexivity
                           | progress break_innermost_match_hyps
                           | solve [ eauto with nocore ]
                           | progress cbv [ZRange.is_bounded_by_bool is_tighter_than_bool] in *
                           | progress rewrite ?Bool.andb_true_iff in *
                           | discriminate
                           | apply conj
                           | Z.ltb_to_lt; lia
                           | match goal with
                             | [ H : context[@Compilers.base.interp_beq _ _ ?base_interp_beq ?t] |- _ ]
                               => progress Reflect.reflect_beq_to_eq (@Compilers.base.interp_beq _ _ base_interp_beq t)
                             | [ |- context[@Compilers.base.interp_beq _ _ ?base_interp_beq ?t] ]
                               => progress Reflect.reflect_beq_to_eq (@Compilers.base.interp_beq _ _ base_interp_beq t)
                             end ].
            { lazymatch goal with
              | [ r1 : list (interp t), r2 : list (interp t), val : list (binterp t) |- _ ]
                => revert r1 r2 val Htight Hbounds IHt
              end; intros r1 r2 val; revert r1 r2 val.
              induction r1, r2, val; cbn; auto with nocore; try congruence; [].
              rewrite !Bool.andb_true_iff; intros; destruct_head'_and; split; eauto with nocore. }
          Qed.

          Lemma is_tighter_than_Some_is_bounded_by {t} r1 r2 val
                (Htight : @is_tighter_than t r1 (Some r2) = true)
                (Hbounds : is_bounded_by r1 val = true)
            : base.is_bounded_by r2 val = true.
          Proof.
            rewrite <- is_bounded_by_Some.
            eapply is_tighter_than_is_bounded_by; eassumption.
          Qed.
        End option.
      End base.

      (** turn a [type] into a [Set] describing the type of bounds on
          that type; this lifts [base.interp] from
          [type.base] to [type] *)
      Definition interp (t : type base.type)
        := type.interp base.interp t.
      Definition is_tighter_than {t} : interp t -> interp t -> bool
        := match t with
           | type.base x => @base.is_tighter_than x
           | type.arrow s d => fun _ _ => false
           end.
      Definition is_bounded_by {t} : interp t -> einterp t -> bool
        := match t return interp t -> einterp t -> bool with
           | type.base x => @base.is_bounded_by x
           | type.arrow s d => fun _ _ => false
           end.
      Module option.
        (** turn a [type] into a [Set] describing the type of optional
            bounds on that base type; bounds on a [Z] may be either a
            range, or [None], generally indicating that the [Z] is
            unbounded.  This lifts [base.option.interp] from
            [base.type] to [type] *)
        Definition interp (t : type base.type)
          := tinterp_gen base.option.interp t.
        Fixpoint None {t : type base.type} : interp t
          := match t with
             | type.base x => @base.option.None x
             | type.arrow s d => fun _ => @None d
             end.
        Definition Some {t : type base.type} : type.interp t -> interp t
          := match t with
             | type.base x => @base.option.Some x
             | type.arrow s d => fun _ _ => @None d
             end.
        Fixpoint strip_ranges {t : type base.type} : interp t -> interp t
          := match t with
             | type.base x => @base.option.strip_ranges x
             | type.arrow s d => fun f x => @strip_ranges d (f x)
             end.
        Definition is_tighter_than {t} : interp t -> interp t -> bool
          := match t with
             | type.base x => @base.option.is_tighter_than x
             | type.arrow s d => fun _ _ => false
             end.
        Definition is_bounded_by {t} : interp t -> einterp t -> bool
          := match t with
             | type.base x => @base.option.is_bounded_by x
             | type.arrow s d => fun _ _ => false
             end.

        Lemma is_bounded_by_Some {t} r val
          : is_bounded_by (@Some t r) val = type.is_bounded_by r val.
        Proof.
          induction t; [ apply base.option.is_bounded_by_Some | reflexivity ].
        Qed.

        Lemma is_tighter_than_is_bounded_by {t} r1 r2 val
              (Htight : @is_tighter_than t r1 r2 = true)
              (Hbounds : is_bounded_by r1 val = true)
          : is_bounded_by r2 val = true.
        Proof.
          induction t; cbn in *;
            eauto using base.option.is_tighter_than_is_bounded_by.
        Qed.

        Lemma is_tighter_than_Some_is_bounded_by {t} r1 r2 val
              (Htight : @is_tighter_than t r1 (Some r2) = true)
              (Hbounds : is_bounded_by r1 val = true)
          : type.is_bounded_by r2 val = true.
        Proof.
          rewrite <- is_bounded_by_Some.
          eapply is_tighter_than_is_bounded_by; eassumption.
        Qed.
      End option.
    End type.

    Module ident.
      Module option.
        Local Open Scope zrange_scope.

        Fixpoint of_literal {t} : base.interp t -> type.base.option.interp t
          := match t with
             | base.type.type_base base.type.Z => fun z => Some r[z~>z]%zrange
             | base.type.type_base _
               => fun n => Some n
             | base.type.unit
               => fun _ => tt
             | base.type.prod A B
               => fun '(a, b) => (@of_literal A a, @of_literal B b)
             | base.type.list A
               => fun ls => Some (List.map (@of_literal A) ls)
             | base.type.option A
               => fun v => Some (option_map (@of_literal A) v)
             end.
        Fixpoint to_literal {t} : type.base.option.interp t -> option (base.interp t)
          := match t with
             | base.type.type_base base.type.Z => fun r => r <- r; if r.(lower) =? r.(upper) then Some r.(lower) else None
             | base.type.type_base _
               => fun v => v
             | base.type.unit
               => fun _ => Some tt
             | base.type.prod A B
               => fun '(a, b) => a <- @to_literal A a; b <- @to_literal B b; Some (a, b)
             | base.type.list A
               => fun ls => ls <- ls; Option.List.lift (List.map (@to_literal A) ls)
             | base.type.option A
               => fun v => v <- v; Option.lift (option_map (@to_literal A) v)
             end%option%Z.
        Local Notation rSome v
          := (ZRange.type.base.option.Some (t:=base.reify_norm_type_of v) v)
               (only parsing).
        (** do bounds analysis on identifiers; take in optional bounds
            on arguments, return optional bounds on outputs. *)
        (** Casts are like assertions; we only guarantee anything when they're true *)
        (** If [r] is [None], that means we had a cast with a
            non-literal range.  If [v] is [None], that means we don't
            know anything about bounds on [v]. *)
        Definition interp_Z_cast (r : option zrange) (v : option zrange) : option zrange
          := match r, v with
             | Some r, Some v
               => if is_tighter_than_bool v r (* the value is definitely inside the range *)
                  then Some v
                  else None
             | _, _ => None
             end.
        (** Here we guarantee truncating/modular behavior of casting *)
        Definition interp_Z_cast_truncate (r : option zrange) (v : option zrange) : option zrange
          := match interp_Z_cast r v, r with
             | Some x, _ => Some x
             | None, Some r => Some (ZRange.normalize r)
             | None, None => None
             end.
        Local Notation tZ := (base.type.type_base base.type.Z).
        Definition interp (assume_cast_truncates : bool) {t} (idc : ident t) : type.option.interp t
          := let interp_Z_cast := if assume_cast_truncates then interp_Z_cast_truncate else interp_Z_cast in
             match idc in ident.ident t return type.option.interp t with
             | ident.Literal t v => @of_literal (base.type.type_base t) v
             | ident.comment _
             | ident.comment_no_keep _
               => fun _ => tt
             | ident.tt as idc
               => ident.interp idc
             | ident.Nat_succ as idc
             | ident.Nat_pred as idc
               => option_map (ident.interp idc)
             | ident.Z_of_nat as idc
               => option_map (fun n => r[Z.of_nat n~>Z.of_nat n]%zrange)
             | ident.Z_to_nat as idc
               => fun v => v <- to_literal v; Some (ident.interp idc v)
             | ident.List_length _
               => option_map (@List.length _)
             | ident.value_barrier
               => fun x => x
             | ident.Nat_max as idc
             | ident.Nat_mul as idc
             | ident.Nat_add as idc
             | ident.Nat_sub as idc
             | ident.Nat_eqb as idc
             | ident.List_seq as idc
               => fun x y => x <- x; y <- y; rSome (ident.interp idc x y)
             | ident.List_repeat _
               => fun x y => y <- y; Some (repeat x y)
             | ident.List_firstn _
               => fun n ls => n <- n; ls <- ls; Some (firstn n ls)
             | ident.List_skipn _
               => fun n ls => n <- n; ls <- ls; Some (skipn n ls)
             | ident.List_combine _ _
               => fun x y => x <- x; y <- y; Some (List.combine x y)
             | ident.List_flat_map _ _
               => fun f ls
                 => (ls <- ls;
                      let fls := List.map f ls in
                      List.fold_right
                        (fun ls1 ls2 => ls1 <- ls1; ls2 <- ls2; Some (ls1 ++ ls2))
                        (Some nil)
                        fls)
             | ident.List_partition _
               => fun f ls
                 => match ls with
                   | Some ls
                     => list_rect
                         _
                         (Some nil, Some nil)
                         (fun x tl partition_tl
                          => let '(g, d) := partition_tl in
                            ((fx <- f x;
                                if fx then (g <- g; Some (x::g)) else g),
                             (fx <- f x;
                                if fx then d else (d <- d; Some (x::d)))))
                         ls
                   | None => (None, None)
                   end
             | ident.Z_eqb as idc
             | ident.Z_leb as idc
             | ident.Z_ltb as idc
             | ident.Z_geb as idc
             | ident.Z_gtb as idc
             | ident.Z_max as idc
             | ident.Z_min as idc
             | ident.Z_pow as idc
             | ident.Z_lxor as idc
             | ident.Z_modulo as idc
             | ident.Build_zrange as idc
               => fun x y => match to_literal x, to_literal y with
                             | Some x, Some y => of_literal (ident.interp idc x y)
                             | _, _ => ZRange.type.base.option.None
                             end
             | ident.Z_ltz as idc
               => fun x y => match to_literal x, to_literal y with
                             | Some x, Some y => of_literal (ident.interp idc x y)
                             | _, _ => Some r[0~>1]
                             end
             | ident.Z_bneg as idc
               => fun x => match to_literal x with
                           | Some x => of_literal (ident.interp idc x)
                           | None => Datatypes.Some r[0~>1]
                           end
             | ident.Z_lnot_modulo as idc
               => fun v m
                 => match to_literal m, to_literal v with
                   | Some m, Some v => of_literal (ident.interp idc v m)
                   | Some m, None => (if (0 <? m)%Z
                                           then Some r[0 ~> m-1]
                                           else if (m =? 0)%Z
                                                then ltac:(match eval hnf in (1 mod 0) with | 0 => exact r[0 ~> 0] | _ => exact None (* if `_ mod 0` is not constant and neither is `v`, we do not bother computing the bounds of `Z.lnot v` *) end)
                                                else Some r[m+1 ~> 0])
                   | _, _ => None
                    end
             | ident.Z_truncating_shiftl as idc
               => fun bw x y => match to_literal bw, to_literal x, to_literal y with
                                | Some bw, Some x, Some y => of_literal (ident.interp idc bw x y)
                                | Some bw, _, _
                                  => x <- x;
                                       y <- y;
                                       Some (ZRange.land_bounds
                                               (ZRange.four_corners_and_zero Z.shiftl x y)
                                               (ZRange.constant (Z.ones (ltac:(match eval hnf in (1 mod 0) with | 0 => exact (Z.max 0 bw) | _ => exact bw end)))))
                                | None, _, _ => None
                                end
             | ident.bool_rect _
               => fun t f b
                 => match b with
                   | Some b => if b then t tt else f tt
                   | None => ZRange.type.base.option.None
                   end
             | ident.bool_rect_nodep _
               => fun t f b
                 => match b with
                   | Some b => if b then t else f
                   | None => ZRange.type.base.option.None
                   end
             | ident.option_rect _ _
               => fun s n o
                 => match o with
                   | Some o => option_rect _ s (n tt) o
                   | None => ZRange.type.base.option.None
                   end
             | ident.zrange_rect _
               => fun f v
                 => match v with
                    | Some v => ZRange.zrange_rect
                                  _
                                  (fun l u => f (Some (ZRange.constant l)) (Some (ZRange.constant u)))
                                  v
                   | None => ZRange.type.base.option.None
                   end
             | ident.nat_rect _
             | ident.eager_nat_rect _
               => fun O_case S_case n
                 => match n with
                   | Some n
                     => nat_rect
                         _
                         (O_case tt)
                         (fun n' rec => S_case (Some n') rec)
                         n
                   | None => ZRange.type.base.option.None
                   end
             | ident.nat_rect_arrow _ _
             | ident.eager_nat_rect_arrow _ _
               => fun O_case S_case n v
                 => match n with
                   | Some n
                     => nat_rect
                         _
                         O_case
                         (fun n' rec => S_case (Some n') rec)
                         n
                         v
                   | None => ZRange.type.base.option.None
                   end
             | ident.list_rect _ _
             | ident.eager_list_rect _ _
               => fun N C ls
                 => match ls with
                   | Some ls
                     => list_rect
                         _
                         (N tt)
                         (fun x xs rec => C x (Some xs) rec)
                         ls
                   | None => ZRange.type.base.option.None
                   end
             | ident.list_rect_arrow _ _ _
             | ident.eager_list_rect_arrow _ _ _
               => fun N C ls v
                 => match ls with
                   | Some ls
                     => list_rect
                         _
                         N
                         (fun x xs rec => C x (Some xs) rec)
                         ls
                         v
                   | None => ZRange.type.base.option.None
                   end
             | ident.list_case _ _
               => fun N C ls
                 => match ls with
                   | Some ls
                     => list_case
                         _
                         (N tt)
                         (fun x xs => C x (Some xs))
                         ls
                   | None => ZRange.type.base.option.None
                   end
             | ident.List_fold_right _ _
               => fun f v ls
                 => match ls with
                   | Some ls
                     => fold_right f v ls
                   | None => ZRange.type.base.option.None
                   end
             | ident.eager_List_nth_default _
             | ident.List_nth_default _
               => fun d ls n
                 => match ls, n with
                   | Some ls, Some n
                     => nth_default d ls n
                   | _, _ => ZRange.type.base.option.None
                   end
             | ident.List_update_nth _
               => fun n f ls => ls <- ls; n <- n; Some (update_nth n f ls)
             | ident.nil t => Some nil
             | ident.cons t => fun x => option_map (cons x)
             | ident.None t => Some None
             | ident.Some t => fun x => Some (Some x)
             | ident.pair A B => pair
             | ident.fst A B => fst
             | ident.snd A B => snd
             | ident.prod_rect A B P => fun f '(a, b) => f a b
             | ident.List_map _ _
               => fun f ls => ls <- ls; Some (List.map f ls)
             | ident.List_app _
               => fun ls1 ls2 => ls1 <- ls1; ls2 <- ls2; Some (List.app ls1 ls2)
             | ident.List_rev _ => option_map (@List.rev _)
             | ident.Z_opp as idc
             | ident.Z_log2 as idc
             | ident.Z_log2_up as idc
               => fun x => x <- x; Some (ZRange.two_corners (ident.interp idc) x)
             | ident.Z_add as idc
             | ident.Z_mul as idc
             | ident.Z_sub as idc
               => fun x y => x <- x; y <- y; Some (ZRange.four_corners (ident.interp idc) x y)
             | ident.Z_div as idc
             | ident.Z_shiftr as idc
             | ident.Z_shiftl as idc
               => fun x y => x <- x; y <- y; Some (ZRange.four_corners_and_zero (ident.interp idc) x y)
             | ident.Z_add_with_carry as idc
               => fun x y z => x <- x; y <- y; z <- z; Some (ZRange.eight_corners (ident.interp idc) x y z)
             | ident.Z_cc_m as idc
               => fun s x => s <- to_literal s; x <- x; Some (ZRange.two_corners (ident.interp idc s) x)
             | ident.Z_rshi as idc
               => fun s x y offset
                 => s <- to_literal s; x <- x; y <- y; offset <- to_literal offset;
                     if (0 <? s) then Some r[0~>s-1] else None
             | ident.Z_land
               => fun x y => x <- x; y <- y; Some (ZRange.land_bounds x y)
             | ident.Z_lor
               => fun x y => x <- x; y <- y; Some (ZRange.lor_bounds x y)
             | ident.Z_mul_split
               => fun split_at x y
                 => match to_literal split_at, x, y with
                   | Some split_at, Some x, Some y
                     => ZRange.type.base.option.Some
                         (t:=tZ*tZ)
                         (ZRange.split_bounds (ZRange.four_corners Z.mul x y) split_at)
                   | _, _, _ => ZRange.type.base.option.None
                   end
             | ident.Z_mul_high
               => fun split_at x y
                 => match to_literal split_at, x, y with
                   | Some split_at, Some x, Some y
                     => ZRange.type.base.option.Some
                         (t:=tZ)
                         (snd (ZRange.split_bounds (ZRange.four_corners Z.mul x y) split_at))
                   | _, _, _ => ZRange.type.base.option.None
                    end
             | ident.Z_add_get_carry
               => fun split_at x y
                 => match to_literal split_at, x, y with
                   | Some split_at, Some x, Some y
                     => ZRange.type.base.option.Some
                         (t:=tZ*tZ)
                         (ZRange.split_bounds (ZRange.four_corners Z.add x y) split_at)
                   | _, _, _ => ZRange.type.base.option.None
                   end
             | ident.Z_add_with_get_carry
               => fun split_at x y z
                 => match to_literal split_at, x, y, z with
                   | Some split_at, Some x, Some y, Some z
                     => ZRange.type.base.option.Some
                         (t:=tZ*tZ)
                         (ZRange.split_bounds
                            (ZRange.eight_corners (fun x y z => (x + y + z)%Z) x y z)
                            split_at)
                   | _, _, _, _ => ZRange.type.base.option.None
                   end
             | ident.Z_sub_get_borrow
               => fun split_at x y
                 => match to_literal split_at, x, y with
                   | Some split_at, Some x, Some y
                     => ZRange.type.base.option.Some
                         (t:=tZ*tZ)
                         (let b := ZRange.split_bounds (ZRange.four_corners BinInt.Z.sub x y) split_at in
                          (* N.B. sub_get_borrow returns - ((x - y) / split_at) as the borrow, so we need to negate *)
                          (fst b, ZRange.opp (snd b)))
                   | _, _, _ => ZRange.type.base.option.None
                   end
             | ident.Z_sub_with_get_borrow
               => fun split_at x y z
                 => match to_literal split_at, x, y, z with
                   | Some split_at, Some x, Some y, Some z
                     => ZRange.type.base.option.Some
                         (t:=tZ*tZ)
                         (let b := ZRange.split_bounds (ZRange.eight_corners (fun x y z => (y - z - x)%Z) x y z) split_at in
                          (* N.B. sub_get_borrow returns - ((x - y) / split_at) as the borrow, so we need to negate *)
                          (fst b, ZRange.opp (snd b)))
                   | _, _, _, _ => ZRange.type.base.option.None
                   end
             | ident.Z_zselect
               => fun _ y z => y <- y; z <- z; Some (ZRange.union y z)
             | ident.Z_add_modulo
               => fun x y m
                 => (x <- x;
                      y <- y;
                      m <- m;
                      Some (ZRange.union
                              (ZRange.four_corners Z.add x y)
                              (ZRange.eight_corners (fun x y m => Z.max 0 (x + y - m))
                                                    x y m)))
             | ident.Z_combine_at_bitwidth as idc
               => fun bitwidth lo hi
                  => bitwidth <- to_literal bitwidth;
                       lo <- lo;
                       hi <- hi;
                       Some (ZRange.four_corners (ident.interp idc bitwidth) lo hi)
             | ident.Z_cast
               => fun (range : option zrange) (r : option zrange)
                  => interp_Z_cast range r
             | ident.Z_cast2
               => fun '((r1, r2) : option zrange * option zrange) '((r1', r2') : option zrange * option zrange)
                  => (interp_Z_cast r1 r1', interp_Z_cast r2 r2')
             | ident.fancy_add
             | ident.fancy_sub
               => fun '((log2wordmax, imm), args)
                  => match to_literal (t:=tZ) log2wordmax, to_literal (t:=tZ) imm with
                     | Some log2wordmax, _
                       => let wordmax := 2^log2wordmax in
                          let r := r[0~>wordmax-1] in
                          if ZRange.type.base.option.is_tighter_than (t:=tZ*tZ) args (Some r, Some r)
                          then (Some r, Some r[0~>1])
                          else ZRange.type.base.option.None
                     | _, _ => ZRange.type.base.option.None
                     end
             | ident.fancy_addc
             | ident.fancy_subb
               => fun '((log2wordmax, imm), args)
                  => match to_literal (t:=tZ) log2wordmax, to_literal (t:=tZ) imm with
                     | Some log2wordmax, _
                       => let wordmax := 2^log2wordmax in
                          let r := r[0~>wordmax-1] in
                          if ZRange.type.base.option.is_tighter_than (t:=tZ*tZ*tZ) args (Some r[0~>1], Some r, Some r)
                          then (Some r, Some r[0~>1])
                          else ZRange.type.base.option.None
                     | _, _ => ZRange.type.base.option.None
                     end
             | ident.fancy_mulll
             | ident.fancy_mullh
             | ident.fancy_mulhl
             | ident.fancy_mulhh
               => fun '(log2wordmax, args)
                  => match to_literal (t:=tZ) log2wordmax with
                     | Some log2wordmax
                       => let wordmax := 2^log2wordmax in
                          let r := r[0~>wordmax-1] in
                          if ZRange.type.base.option.is_tighter_than (t:=tZ*tZ) args (Some r, Some r)
                          then if (Z.eqb (log2wordmax mod 2) 0)
                               then Some r
                               else ZRange.type.base.option.None
                          else ZRange.type.base.option.None
                     | _ => ZRange.type.base.option.None
                     end
             | ident.fancy_rshi as idc
               => fun '((log2wordmax, n), args)
                  => match to_literal (t:=tZ) log2wordmax, to_literal (t:=tZ) n with
                     | Some log2wordmax, Some n
                       => let wordmax := 2^log2wordmax in
                          let r := r[0~>wordmax-1] in
                          let r_nbits := r[0~>2^n-1] in
                          if (0 <=? log2wordmax)%Z
                          then if (ZRange.type.base.option.is_tighter_than (t:=tZ*tZ) args (Some r_nbits, Some r) && (0 <=? n)%Z)
                               then
                                 hi_range <- fst args;
                                   lo_range <- snd args;
                                   Some (ZRange.four_corners (fun x y => ident.interp idc ((log2wordmax, n), (x, y))) hi_range lo_range)
                               else if ZRange.type.base.option.is_tighter_than (t:=tZ*tZ) args (Some r, Some r)
                                    then Some r
                                    else ZRange.type.base.option.None
                          else ZRange.type.base.option.None
                     | _, _ => ZRange.type.base.option.None
                     end
             | ident.fancy_selm
               => fun '(_, (_, y, z)) => y <- y; z <- z; Some (ZRange.union y z)
             | ident.fancy_selc
             | ident.fancy_sell
               => fun '(_, y, z) => y <- y; z <- z; Some (ZRange.union y z)
             | ident.fancy_addm
               => fun '(x, y, m)
                  => (x <- x;
                        y <- y;
                        m <- m;
                        Some (ZRange.union
                                (ZRange.four_corners Z.add x y)
                                (ZRange.eight_corners (fun x y m => Z.max 0 (x + y - m))
                                                      x y m)))
             end%option.
      End option.
    End ident.
  End ZRange.
End Compilers.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg.
From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv.

From CoqEAL Require Import hrel param refinements poly_op.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.
Import Refinements.Op Poly.Op.

Local Open Scope ring_scope.
Local Open Scope rel.

Section karatsuba_generic.

Variable polyA N : Type.

Context `{add_of polyA, mul_of polyA, sub_of polyA}.
Context `{shiftp : shift_of polyA N, sizep : size_of polyA N}.
Context `{splitp : split_of polyA N}.
Context `{one_of N, add_of N, mul_of N, leq_of N}.
Context `{spec_of N nat, implem_of nat N}.

Fixpoint karatsuba_rec n (p q : polyA) := match n with
  | 0     => (p * q)%C
  | n'.+1 =>
      let sp := sizep p in let sq := sizep q in
      if (sp <= 1 + 1)%C || (sq <= 1 + 1)%C then (p * q)%C else
        let m       := implem (minn (spec sp)./2 (spec sq)./2) in
        let (p1,p2) := splitp m p in
        let (q1,q2) := splitp m q in
        let p1q1    := karatsuba_rec n' p1 q1 in
        let p2q2    := karatsuba_rec n' p2 q2 in
        let p12     := (p1 + p2)%C in
        let q12     := (q1 + q2)%C in
        let p12q12  := karatsuba_rec n' p12 q12 in
        (shiftp ((1 + 1) * m)%C p1q1 +
         shiftp m (p12q12 - p1q1 - p2q2) +
         p2q2)%C
  end.

Definition karatsuba p q :=
  karatsuba_rec (maxn (spec (sizep p)) (spec (sizep q))) p q.

End karatsuba_generic.

Parametricity karatsuba_rec.
Parametricity karatsuba.

Section karatsuba_correctness.

Local Open Scope rel_scope.

Variable R : ringType.

Instance add_polyR : add_of {poly R} := +%R.
Instance mul_polyR : mul_of {poly R} := *%R.
Instance sub_polyR : sub_of {poly R} := fun x y => (x - y)%R.
Instance size_polyR : size_of {poly R} nat := sizep (R:=R).
Instance shift_polyR : shift_of {poly R} nat := shiftp (R:=R).
Instance split_polyR : split_of {poly R} nat := splitp (R:=R).

Local Instance one_nat    : one_of nat        := 1%N.
Local Instance add_nat    : add_of nat        := addn.
Local Instance mul_nat    : mul_of nat        := muln.
Local Instance leq_nat    : leq_of nat        := ssrnat.leq.
Local Instance spec_nat   : spec_of nat nat   := spec_id.
Local Instance implem_nat : implem_of nat nat := implem_id.

Lemma karatsuba_recE n (p q : {poly R}) : karatsuba_rec (N:=nat) n p q = p * q.
Proof.
elim: n=> //= n ih in p q *; case: ifP=> // _; set m := minn _ _.
rewrite [p in RHS](rdivp_eq (monicXn _ m)) [q in RHS](rdivp_eq (monicXn _ m)).
rewrite /shift_op /shift_polyR /shiftp /implem /implem_nat /implem_id.
simpC.
rewrite !ih !(mulrDl, mulrDr, mulNr) mulnC exprM.
rewrite -addrA -addrA -opprD [X in X + _ - _]addrC addrACA addrK.
by rewrite !(commr_polyXn, mulrA, addrA).
Qed.

Lemma karatsubaE (p q : {poly R}) : karatsuba (N:=nat) p q = p * q.
Proof. exact: karatsuba_recE. Qed.

Section karatsuba_param.

Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type).
Context (N : Type) (rN : nat -> N -> Type).
Context `{add_of polyC, mul_of polyC, sub_of polyC}.
Context `{one_of N, add_of N, mul_of N, leq_of N}.
Context `{spec_of N nat, implem_of nat N}.
Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) +%R +%C}.
Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) *%R *%C}.
Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) (fun x y => x - y)%R sub_op}.
Context `{!refines rN 1%N 1%C}.
Context `{!refines (rN ==> rN ==> rN) addn +%C}.
Context `{!refines (rN ==> rN ==> rN) muln *%C}.
Context `{!refines (rN ==> rN ==> bool_R) ssrnat.leq leq_op}.
Context `{!refines (rN ==> nat_R) spec_id spec,
          !refines (nat_R ==> rN) implem_id implem}.

Context `{!shift_of polyC N}.
Context `{!refines (rN ==> RpolyC ==> RpolyC) shift_polyR shift_op}.

Context `{!size_of polyC N}.
Context `{!refines (RpolyC ==> rN) size_polyR size_op}.

Context `{!split_of polyC N}.
Context `{!refines (rN ==> RpolyC ==> prod_R RpolyC RpolyC) split_polyR split_op}.

#[export] Instance RpolyC_karatsuba_rec :
  refines (nat_R ==> RpolyC ==> RpolyC ==> RpolyC)
          (karatsuba_rec (polyA:={poly R}) (N:=nat))
          (karatsuba_rec (polyA:=polyC) (N:=N)).
Proof. param karatsuba_rec_R. Qed.

#[export] Instance RpolyC_karatsuba :
  refines (RpolyC ==> RpolyC ==> RpolyC)
    (karatsuba (polyA:={poly R}) (N:=nat)) (karatsuba (polyA:=polyC) (N:=N)).
Proof. param karatsuba_R. Qed.

#[export] Instance RpolyC_karatsuba_mul p sp q sq :
  refines RpolyC p sp -> refines RpolyC q sq ->
  refines RpolyC (p * q) (karatsuba (N:=N) sp sq).
Proof.
  move=> hp hq.
  rewrite refinesE -karatsubaE.
  exact: refinesP.
Qed.

End karatsuba_param.
End karatsuba_correctness.

From mathcomp Require Import ssrint.
From CoqEAL Require Import binnat binint seqpoly.

Section karatsuba_test.

Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X) == 1 + 4%:Z *: 'X + 4%:Z%:P * 'X^2).
by coqeal.
Abort.

Goal (Poly [:: 1; 2%:Z] * Poly [:: 1; 2%:Z]) == Poly [:: 1; 4%:Z; 4%:Z].
by coqeal.
Abort.

Fixpoint bigseq (x : int) (n : nat) : seq int := match n with
  | 0 => [:: x]
  | n'.+1 => x :: bigseq (x+1) n'
  end.

Fixpoint bigpoly (x : int) (n : nat) : {poly int} :=
  match n with
  | 0 => x%:P
  | n.+1 => x%:P + (bigpoly (x+1) n) * 'X
  end.

Let p1 := Eval compute in bigseq 1%N 10.
Let p2 := Eval compute in bigseq 2%N 10.

Let q1 := Eval simpl in bigpoly 1%N 10.
Let q2 := Eval simpl in bigpoly 2%N 10.

(* TODO: Translate Poly directly? *)
Goal (Poly p1 * Poly p2 == Poly p2 * Poly p1).
by coqeal.
Abort.

Goal (q1 * q2 == q2 * q1).
by coqeal.
Abort.

End karatsuba_test.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      - rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  + rewrite 2 drop_Cons_assoc. reflexivity.
  + rewrite 3 drop_Nil. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
lfind.
Admitted.


(***************************************************************************)
(*   This is part of FA_Completeness, it is distributed under the terms    *)
(*           of the GNU Lesser General Public License version 3            *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Import t2.
Require Export Seq.

Definition NestedIntervals a b := Increase a /\
  Decrease b /\ ILT_Seq a b /\ Limit (Minus_Seq b a) O.

Theorem NITex : ∀ a b, NestedIntervals a b ->
  ∃ ξ, (∀ n, a n ≦ ξ /\ ξ ≦ b n) /\ Limit a ξ /\ Limit b ξ.
Proof.
  intros; red in H; destruct H, H0, H1.
  assert (Boundup_Seq (b 1) a).
  { red; intros. red in H, H0, H1; destruct (Theorem24 n).
    - pose proof H3; apply H in H3. eapply Theorem173; eauto.
    - rewrite H3; auto. }
  destruct (MCTup _ _ H H3) as [ξ H4].
  assert (Limit b ξ).
  { rewrite (SeqCon1 a b), <- Theorem175''; apply SeqLimPlus; auto. }
  exists ξ; repeat split; auto.
  - apply Increase_limitP; auto. - apply Decrease_limitP; auto.
Qed.

Theorem NITuni : ∀ a b, NestedIntervals a b -> ∀ ξ1 ξ2,
  (∀ n, a n ≦ ξ1 /\ ξ1 ≦ b n) /\ Limit a ξ1 /\ Limit b ξ1 ->
  (∀ n, a n ≦ ξ2 /\ ξ2 ≦ b n) /\ Limit a ξ2 /\ Limit b ξ2 -> ξ1 = ξ2.
Proof.
  intros; destruct H0 as [_ [H0 _]], H1 as [_ [H1 _]].
  eapply LimUni; eauto.
Qed.

Corollary Cor_NIT: ∀ a b, NestedIntervals a b ->
  ∃ ξ, (∀ N, a N ≦ ξ /\ ξ ≦ b N) /\
  (∀ ε, ε > O -> ∃ N, ∀ n, (IGT_N n N) ->
  [(a n) | (b n)] ⊂ (ξ|-ε)).
Proof.
  intros. apply NITex in H; destruct H as [ξ H], H, H0.
  exists ξ; split; intros; auto.
  destruct H0 with ε as [N1 H3]; auto.
  destruct H1 with ε as [N2 H4]; auto.
  exists (Plus_N N1 N2); intros.
  pose proof (H3 _ (Theorem15 _ _ _ (Theorem18 N1 N2) H5)).
  pose proof (Theorem18 N2 N1); rewrite Theorem6 in H7.
  pose proof (H4 _ (Theorem15 _ _ _ H7 H5)).
  red; intros; destruct H9, H9; constructor; split.
  - apply Ab1 in H6; destruct H6.
    apply Theorem172 with (Γ:=a n); right; split; auto.
    apply Theorem188_1' with (Θ:=ξ) in H6; Simpl_Rin H6.
    rewrite Theorem175 in H6; auto.
  - apply Ab1 in H8; destruct H8.
    apply Theorem172 with (Γ:=b n); left; split; auto.
    apply Theorem188_1' with (Θ:=ξ) in H11; Simpl_Rin H11.
    rewrite Theorem175; auto.
Qed.


Require Import List.
Require Import Undecidability.PCP.PCP.

(* A string is a list of symbols. *)
Definition string X := list X.

Notation "x / y" := (x, y).

(* A string rewriting system SRS is a list of rules x / y
  such that x rewrites to y. *)
Definition SRS X := list (string X * string X).

(* If u / v is a rewriting rule, then u ++ x rewrites to x ++ u. *)
Inductive der {X : Type} (R : SRS X) : string X -> string X -> Prop :=
  derB x u v : In (u / v) R -> der R (u ++ x) (x ++ v).
(* rewt is the reflexive, transitive closure of rew. *)
Inductive derv {X : Type} (R : SRS X) : string X -> string X -> Prop :=
  derR z : derv R z z
| derS x y z : der R x y -> derv R y z -> derv R x z.

(* String rewriting PCSnf is
  given a Post canonical system in normal form R and two strings x and y,
  determine whether x rewrites to y in R. *)
Definition PCSnf : SRS nat * string nat * string nat -> Prop :=
  fun '(R, x, y) => derv R x y.


Require Import List.
Import ListNotations.

Require Import Classes.SetoidClass.

Require Import Recdef.
Require Import Coq.Program.Wf.

Inductive D : Set :=
| O : D
| I : D.

Definition bin : Set := list D.

Inductive bin_equiv : bin -> bin -> Prop :=
| equiv_refl : forall b : bin, bin_equiv b b
| equiv_sym : forall b b' : bin, bin_equiv b b' -> bin_equiv b' b
| equiv_trans : forall b1 b2 b3 : bin,
    bin_equiv b1 b2 -> bin_equiv b2 b3 -> bin_equiv b1 b3
| equiv_nil : bin_equiv [O] []
| equiv_leading_zeros : forall b b' : bin,
    bin_equiv b b' -> bin_equiv (O :: b) b'.

#[global] Hint Constructors bin_equiv : core.

#[refine]
#[export]
Instance bin_setoid : Setoid bin :=
{
  equiv := bin_equiv
}.
Proof.
  split; red; eauto.
Qed.

Fixpoint normalize (b : bin) : bin :=
match b with
| [] => []
| O :: b' => normalize b'
| _ => b
end.

Lemma normalize_spec :
  forall b : bin, bin_equiv b (normalize b).
Proof.
  induction b as [| d ds].
    cbn. eauto.
    destruct d; cbn.
      apply equiv_leading_zeros. assumption.
      constructor.
Qed.

Fixpoint bin_to_nat' (b : bin) : nat :=
match b with
| [] => 0
| O :: b' => 2 * bin_to_nat' b'
| I :: b' => 1 + 2 * bin_to_nat' b'
end.

Definition bin_to_nat (b : bin) : nat :=
    bin_to_nat' (rev (normalize b)).

Eval compute in bin_to_nat [I; O; I; O; I; O].

Function divmod2 (n : nat) : nat * D :=
match n with
| 0 => (0, O)
| 1 => (0, I)
| S (S n') => let (a, b) := divmod2 n' in (S a, b)
end.

Fixpoint nat_ind_2 (P : nat -> Prop) (H0 : P 0) (H1 : P 1)
    (H : forall n : nat, P n -> P (S (S n))) (n : nat) : P n :=
match n with
| 0 => H0
| 1 => H1
| S (S n') => H n' (nat_ind_2 P H0 H1 H n')
end.

Ltac inv H := inversion H; subst; clear H.

Lemma divmod2_spec :
  forall (n m : nat) (d : D),
    divmod2 n = (m, d) -> m = 0 \/ m < n.
Proof.
  induction n using nat_ind_2; cbn; intros; inv H.
  - left. reflexivity.
  - left. reflexivity.
  - destruct (divmod2 n). inv H1. destruct (IHn _ _ eq_refl).
    + right. rewrite H. do 2 apply le_n_S. apply le_0_n.
    + right. apply le_n_S. apply le_S. assumption.
Qed.

Function nat_to_bin' (n : nat) {measure id n} : bin :=
  let
    '(a, b) := divmod2 n
  in
    match a with
    | 0 => [b]
    | _ => b :: nat_to_bin' a
    end.
Proof.
  intros.
  destruct (divmod2_spec _ _ _ teq); subst.
  - inv H.
  - unfold id. assumption.
Defined.

Definition nat_to_bin (n : nat) : bin := rev (nat_to_bin' n).

Goal
  forall n : nat, bin_to_nat (nat_to_bin n) = n.
Proof.
  unfold nat_to_bin. intro.
  functional induction (nat_to_bin' n). cbn.
    destruct b; cbn.
      functional inversion e. reflexivity.
      functional inversion e. reflexivity.
    cbn. unfold bin_to_nat in IHb. destruct a.
      contradiction.
      functional inversion e. subst.
Abort.

Compute bin_to_nat [I; O; I; O].
Compute bin_to_nat [I; O; O; O; I; I; I; I; O; I; I; O; I; I; I].


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.covyoneda.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.

Local Open Scope container_scope.
Local Open Scope set.
Local Open Scope cat.

Definition interpret_container
           (C : container)
           (X : hSet)
  : hSet
  := ∑ (s : shapes C), funset (positions C s) X.

Notation "⟦ C ⟧ X" := (interpret_container C X) (at level 70) : container_scope.
(** \[[ and \]] *)

(** Relevant builders *)
Definition shape_of
           {C : container}
           {X : hSet}
           (x : ⟦ C ⟧ X)
  : shapes C
  := pr1 x.

Definition position_of
           {C : container}
           {X : hSet}
           (x : ⟦ C ⟧ X)
  : positions C (shape_of x) → X
  := pr2 x.

Definition cpair
           {C : container}
           {X : hSet}
           (s : shapes C)
           (f : positions C s → X)
  : ⟦ C ⟧ X
  := s ,, f.

(** The action on maps and the functor laws *)
Definition interpret_container_map
           (C : container)
           {X Y : hSet}
           (f : X → Y)
  : ⟦ C ⟧ X → ⟦ C ⟧ Y
  := λ x, cpair (shape_of x) (λ p, f (position_of x p)).

Definition container_to_functor_data
           (C : container)
  : functor_data HSET HSET.
Proof.
  use make_functor_data.
  - exact (λ Z, ⟦ C ⟧ Z).
  - exact (@interpret_container_map C).
Defined.

Definition container_is_functor
           (C : container)
  : is_functor (container_to_functor_data C).
Proof.
  split.
  - intros X.
    apply idpath.
  - intros X Y Z f g.
    apply idpath.
Qed.

Definition container_to_functor
           (C : container)
  : SET ⟶ SET.
Proof.
  use make_functor.
  - exact (container_to_functor_data C).
  - exact (container_is_functor C).
Defined.

(** The interpretations of the standard containers correspond with what's expected *)
Definition interpret_const_to_const
           {A : hSet}
           {X : hSet}
  : ⟦ A ⟧ X → A
  := λ x, shape_of x.

Definition const_to_interpret_const
           {A : hSet}
           {X : hSet}
  : A → ⟦ A ⟧ X
  := λ a, @cpair (constant_container _) _ a fromempty.

Definition interpret_const_to_const_to_interpret_const
           {A : hSet}
           {X : hSet}
           (x : ⟦ A ⟧ X)
  : const_to_interpret_const (interpret_const_to_const x) = x.
Proof.
  destruct x as [ s f ].
  unfold const_to_interpret_const, cpair ; cbn.
  apply maponpaths.
  use funextsec.
  intro z.
  destruct z.
Qed.

Definition const_to_interpret_const_to_const
           {A : hSet}
           {X : hSet}
           (a : A)
  : interpret_const_to_const (const_to_interpret_const a : ⟦ _ ⟧ X) = a.
Proof.
  apply idpath.
Qed.

Definition interpret_const
           (A : hSet)
           (X : hSet)
  : ⟦ A ⟧ X ≃ A.
Proof.
  use make_weq.
  - exact interpret_const_to_const.
  - use gradth.
    + exact const_to_interpret_const.
    + exact interpret_const_to_const_to_interpret_const.
    + exact const_to_interpret_const_to_const.
Defined.

Definition interpret_const_nat_trans
           (A : hSet)
  : container_to_functor A ⟹ constant_functor HSET HSET A.
Proof.
  use make_nat_trans.
  - exact (λ _, interpret_const_to_const).
  - abstract
      (intros X Y f ;
       apply idpath).
Defined.

Definition interpret_const_nat_iso
           (A : hSet)
  : nat_iso
      (container_to_functor A)
      (constant_functor HSET HSET A).
Proof.
  use make_nat_iso.
  - exact (interpret_const_nat_trans A).
  - intro X.
    exact (hset_equiv_is_iso _ _ (interpret_const A X)).
Defined.

Definition interpret_identity_to_identity
           {X : hSet}
  : ⟦ I ⟧ X → X
  := λ x, position_of x tt.

Definition identity_to_interpret_identity
           {X : hSet}
  : X → ⟦ I ⟧ X
  := λ x, @cpair identity_container _ tt (λ _, x).

Definition interpret_identity_to_identity_to_interpret_identity
           {X : hSet}
           (x : ⟦ I ⟧ X)
  : identity_to_interpret_identity (interpret_identity_to_identity x) = x.
Proof.
  destruct x as [ [ ] f ].
  unfold identity_to_interpret_identity ; cbn.
  apply maponpaths.
  use funextsec.
  intro z.
  destruct z.
  apply idpath.
Qed.

Definition identity_to_interpret_identity_to_identity
           {X : hSet}
           (x : X)
  : interpret_identity_to_identity (identity_to_interpret_identity x) = x.
Proof.
  apply idpath.
Qed.

Definition interpret_identity
           (X : hSet)
  : ⟦ I ⟧ X ≃ X.
Proof.
  use make_weq.
  - exact interpret_identity_to_identity.
  - use gradth.
    + exact identity_to_interpret_identity.
    + exact interpret_identity_to_identity_to_interpret_identity.
    + exact identity_to_interpret_identity_to_identity.
Defined.

Definition interpret_identity_nat_trans
  : container_to_functor I ⟹ functor_identity HSET.
Proof.
  use make_nat_trans.
  - exact @interpret_identity_to_identity.
  - abstract
      (intros X Y f ;
       apply idpath).
Defined.

Definition interpret_identity_nat_iso
  : nat_iso
      (container_to_functor I)
      (functor_identity HSET).
Proof.
  use make_nat_iso.
  - exact interpret_identity_nat_trans.
  - intro X.
    exact (hset_equiv_is_iso _ _ (interpret_identity X)).
Defined.

Definition interpret_prod_to_prod
           {C₁ C₂ : container}
           {X : hSet}
  : ⟦ C₁ ⊗ C₂ ⟧ X → ⟦ C₁ ⟧ X × ⟦ C₂ ⟧ X
  := λ z, cpair (pr1 (shape_of z)) (λ p, position_of z (inl p))
          ,,
          cpair (pr2 (shape_of z)) (λ p, position_of z (inr p)).

Definition prod_to_interpret_prod
           {C₁ C₂ : container}
           {X : hSet}
  : ⟦ C₁ ⟧ X × ⟦ C₂ ⟧ X → ⟦ C₁ ⊗ C₂ ⟧ X
  := λ z, @cpair
            (prod_container _ _)
            _
            (shape_of (pr1 z) ,, shape_of (pr2 z))
            (coprod_rect _ (position_of (pr1 z)) (position_of (pr2 z))).

Definition interpret_prod_to_prod_to_interpret_prod
           {C₁ C₂ : container}
           {X : hSet}
           (x : ⟦ C₁ ⊗ C₂ ⟧ X)
  : prod_to_interpret_prod (interpret_prod_to_prod x) = x.
Proof.
  destruct x as [ [ s₁ s₂ ] f ].
  unfold interpret_prod_to_prod, prod_to_interpret_prod ; cbn.
  apply maponpaths.
  use funextsec.
  intro z.
  destruct z as [ z | z ].
  - apply idpath.
  - apply idpath.
Qed.

Definition prod_to_interpret_prod_to_prod
           {C₁ C₂ : container}
           {X : hSet}
           (x : ⟦ C₁ ⟧ X × ⟦ C₂ ⟧ X)
  : interpret_prod_to_prod (prod_to_interpret_prod x) = x.
Proof.
  apply idpath.
Qed.

Definition interpret_prod
           (C₁ C₂ : container)
           (X : hSet)
  : ⟦ C₁ ⊗ C₂ ⟧ X ≃ ⟦ C₁ ⟧ X × ⟦ C₂ ⟧ X.
Proof.
  use make_weq.
  - exact interpret_prod_to_prod.
  - use gradth.
    + exact prod_to_interpret_prod.
    + exact interpret_prod_to_prod_to_interpret_prod.
    + exact prod_to_interpret_prod_to_prod.
Defined.

Definition interpret_prod_nat_trans
           (C₁ C₂ : container)
  : container_to_functor (C₁ ⊗ C₂)
    ⟹
    BinProduct_of_functors
      _ _
      BinProductsHSET
      (container_to_functor C₁)
      (container_to_functor C₂).
Proof.
  use make_nat_trans.
  - exact (@interpret_prod_to_prod C₁ C₂).
  - abstract
      (intros X Y f ;
       apply idpath).
Defined.

Definition interpret_prod_nat_iso
           (C₁ C₂ : container)
  : nat_iso
      (container_to_functor (C₁ ⊗ C₂))
      (BinProduct_of_functors
         _ _
         BinProductsHSET
         (container_to_functor C₁)
         (container_to_functor C₂)).
Proof.
  use make_nat_iso.
  - exact (interpret_prod_nat_trans C₁ C₂).
  - intro X.
    exact (hset_equiv_is_iso
             (⟦ C₁ ⊗ C₂ ⟧ X)
             (⟦ C₁ ⟧ X × ⟦ C₂ ⟧ X)
             (interpret_prod C₁ C₂ X)).
Defined.

Definition interpret_sum_to_sum
           {C₁ C₂ : container}
           {X : hSet}
  : ⟦ C₁ ⊕ C₂ ⟧ X → (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X).
Proof.
  intros x.
  induction x as [x y].
  induction x as [x | x].
  - exact (inl (x ,, y)).
  - exact (inr (x ,, y)).
Defined.

Definition sum_to_interpret_sum
           {C₁ C₂ : container}
           {X : hSet}
  : (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X) → ⟦ C₁ ⊕ C₂ ⟧ X.
Proof.
  intros x.
  induction x as [x | x].
  - induction x as [x y].
    exact (inl x ,, y).
  - induction x as [x y].
    exact (inr x ,, y).
Defined.

Definition sum_to_interpret_sum_to_sum
           {C₁ C₂ : container}
           {X : hSet}
           (x : (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X))
  : interpret_sum_to_sum (sum_to_interpret_sum x) = x.
Proof.
  induction x as [x | x].
  - induction x as [x y].
    apply idpath.
  - induction x as [x y].
    apply idpath.
Qed.

Definition interpret_sum_to_sum_to_interpret_sum
           {C₁ C₂ : container}
           {X : hSet}
           (x : ⟦ C₁ ⊕ C₂ ⟧ X)
  : sum_to_interpret_sum (interpret_sum_to_sum x) = x.
Proof.
  induction x as [x y].
  induction x as [x | x].
  - apply idpath.
  - apply idpath.
Qed.

Definition interpret_sum
           {C₁ C₂ : container}
           (X : hSet)
  : ⟦ C₁ ⊕ C₂ ⟧ X ≃ (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X).
Proof.
  use make_weq.
  - exact interpret_sum_to_sum.
  - use gradth.
    + exact sum_to_interpret_sum.
    + exact interpret_sum_to_sum_to_interpret_sum.
    + exact sum_to_interpret_sum_to_sum.
Defined.

Definition interpret_sum_nat_trans
           (C₁ C₂ : container)
  : container_to_functor (C₁ ⊕ C₂)
    ⟹
    BinCoproduct_of_functors
      _ _
      BinCoproductsHSET
      (container_to_functor C₁)
      (container_to_functor C₂).
Proof.
  use make_nat_trans.
  - exact (@interpret_sum_to_sum _ _).
  - abstract
      (intros x y f ;
       use funextsec ;
       intros z ;
       induction z as [z₁ z₂] ;
       induction z₁ ; cbn ; apply idpath).
Defined.

Definition interpret_sum_nat_iso
           (C₁ C₂ : container)
  : nat_iso
      (container_to_functor (C₁ ⊕ C₂))
      (BinCoproduct_of_functors
         _ _
         BinCoproductsHSET
         (container_to_functor C₁)
         (container_to_functor C₂)).
Proof.
  use make_nat_iso.
  - exact (interpret_sum_nat_trans C₁ C₂).
  - intro X.
    exact (hset_equiv_is_iso
             (⟦ C₁ ⊕ C₂ ⟧ X)
             (setcoprod (⟦ C₁ ⟧ X) (⟦ C₂ ⟧ X))
             (interpret_sum X)).
Defined.

(* Interpretation of exponentials *)
Definition container_exp_functor
           (A : hSet)
           (F : HSET ⟶ HSET)
  : HSET ⟶ HSET
  := F ∙ exponential_functor A.

Definition interpret_exp_to_exp
           {C : container}
           {A X : hSet}
  : ⟦ C ^ A ⟧ X → (A → ⟦ C ⟧ X).
Proof.
  intros f a.
  refine (pr1 f a ,, _).
  exact (λ p, pr2 f (a ,, p)).
Defined.

Definition exp_to_interpret_exp
           {C : container}
           {A X : hSet}
  : (A → ⟦ C ⟧ X) → ⟦ C ^ A ⟧ X.
Proof.
  intros f.
  simple refine (_ ,, _).
  - exact (λ a, pr1 (f a)).
  - exact (λ x, pr2 (f (pr1 x)) (pr2 x)).
Defined.

Definition exp_to_interpret_exp_to_exp
           {C : container}
           {A X : hSet}
           (f : A → ⟦ C ⟧ X)
  : interpret_exp_to_exp (exp_to_interpret_exp f) = f.
Proof.
  apply idpath.
Qed.

Definition interpret_exp_to_exp_to_interpret_exp
           {C : container}
           {A X : hSet}
           (x : ⟦ C ^ A ⟧ X)
  : exp_to_interpret_exp (interpret_exp_to_exp x) = x.
Proof.
  apply idpath.
Qed.

Definition interpret_exp
           {C : container}
           {A : hSet}
           (X : hSet)
  : ⟦ C ^ A ⟧ X ≃ (A → ⟦ C ⟧ X).
Proof.
  use make_weq.
  - exact interpret_exp_to_exp.
  - use gradth.
    + exact exp_to_interpret_exp.
    + exact interpret_exp_to_exp_to_interpret_exp.
    + exact exp_to_interpret_exp_to_exp.
Defined.

Definition interpret_exp_nat_trans
           (C : container)
           (A : hSet)
  : container_to_functor (C ^ A)
    ⟹
    container_exp_functor A (container_to_functor C).
Proof.
  use make_nat_trans.
  - exact (@interpret_exp_to_exp C A).
  - abstract
      (intros X Y f ; cbn ;
       apply idpath).
Defined.

Definition interpret_exp_nat_iso
           (C : container)
           (A : hSet)
  : nat_iso
      (container_to_functor (C ^ A))
      (container_exp_functor A (container_to_functor C)).
Proof.
  use make_nat_iso.
  - exact (interpret_exp_nat_trans C A).
  - intro X.
    exact (hset_equiv_is_iso
             (⟦ C ^ A ⟧ X)
             (funset A (⟦ C ⟧ X))
             (interpret_exp X)).
Defined.

Definition sem_endpoint
           {P : container}
           {X : hSet}
           {Q : hSet}
           (c : ⟦ P ⟧ X → X)
           (x : W P Q)
           (var : Q → X)
  : X.
Proof.
  induction x as [ v | s p IHp ].
  - exact (var v).
  - exact (c (s ,, IHp)).
Defined.

Definition sem_endpoint_is_nat_trans
           {P : container}
           {X Y : total_precategory (fun_algebra_disp_cat (container_to_functor P))}
           (f : X --> Y)
           {Q : hSet}
           (x : W P Q)
           (var : Q → (pr1 X : hSet))
  : sem_endpoint (pr2 Y) x (λ x0 : Q, pr1 f (var x0))
    =
    pr1 f (sem_endpoint (pr2 X) x var).
Proof.
  induction x as [ v | s p IHp ].
  - apply idpath.
  - refine (_ @ !(eqtohomot (pr2 f) _)) ; cbn.
    apply maponpaths.
    unfold interpret_container_map ; cbn.
    apply maponpaths.
    apply funextsec.
    exact IHp.
Qed.

Definition forgetful_container
           (P : container)
  : total_precategory (fun_algebra_disp_cat (container_to_functor P)) ⟶ SET
  := pr1_category (fun_algebra_disp_cat (container_to_functor P)).

Definition sem_endpoint_nat_trans
           {P : container}
           {Q : hSet}
           (x : W P Q)
  : forgetful_container P ∙ covyoneda _ has_homsets_HSET Q
    ⟹
    forgetful_container P.
Proof.
  use make_nat_trans.
  - exact (λ X var, sem_endpoint (pr2 X) x var).
  - abstract
      (intros X Y f ;
       apply funextsec ;
       exact (sem_endpoint_is_nat_trans f x)).
Defined.

Definition hit_prealgebra
           (Σ : hit_signature)
  : category
  := total_category
       (fun_algebra_disp_cat
          (container_to_functor (point_constr Σ))).

Section Accessors.
  Context {Σ : hit_signature}
          (X : hit_prealgebra Σ).

  Definition alg_carrier : hSet
    := pr1 X.

  Definition algebra_map
    : ⟦ point_constr Σ ⟧ alg_carrier → alg_carrier
    := pr2 X.
End Accessors.

Definition make_hit_prealgebra
           {Σ : hit_signature}
           (X : hSet)
           (f : ⟦ point_constr Σ ⟧ X → X)
  : hit_prealgebra Σ
  := X ,, f.

Close Scope set.

Definition is_hit_algebra
           {Σ : hit_signature}
           (X : hit_prealgebra Σ)
  : UU
  := ∏ (i : path_index Σ)
       (p : path_arg Σ i → alg_carrier X),
     sem_endpoint (algebra_map X) (path_lhs Σ i) p
     =
     sem_endpoint (algebra_map X) (path_rhs Σ i) p.

Definition hit_algebra_disp_cat
           (Σ : hit_signature)
  : disp_cat (hit_prealgebra Σ)
  := disp_full_sub _ is_hit_algebra.

Definition hit_algebra
           (Σ : hit_signature)
  : category
  := total_category (hit_algebra_disp_cat Σ).

Definition hit_algebra_map_eq
           {Σ : hit_signature}
           {X Y : hit_algebra Σ}
           {f g : X --> Y}
           (p : ∏ x, pr11 f x = pr11 g x)
  : f = g.
Proof.
  use subtypePath.
  {
    intro ; apply isapropunit.
  }
  use subtypePath.
  {
    intro ; apply homset_property.
  }
  use funextsec.
  exact p.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) : natural := mult Zero y.