-------------------------------------------------------------------------------

--
-- SET (in Hedberg library) for agda2
--  as of 2006.9.29 morning
--  Yoshiki.
--
module SET where
  ----------------------------------------------------------------------------
  -- Auxiliary.
  ----------------------------------------------------------------------------
  -- no : (x : A) -> B : Set  if A : Set B : Set
  -- yes : (x : A) -> B type   if A type  B type
  -- El M type   if  M : Set

  data Unop (A : Set) : Set1 where
    unopI : (A -> A) -> Unop A
  data Pred (A : Set) : Set1 where
    PredI : (A -> Set) -> Pred A
  data Rel (A : Set) : Set1 where
    RelI : (A -> A -> Set) -> Rel A
  data Reflexive {A : Set} (R : A -> A -> Set) : Set where
    reflexiveI : ((a : A) -> R a a) -> Reflexive R
  data Symmetrical {A : Set} (R : A -> A -> Set) : Set where
    symmetricalI : ({a b : A} -> R a b -> R a b) -> Symmetrical R
  data Transitive {A : Set} (R : A -> A -> Set) : Set where
    transitiveI : ({a b c : A} -> R a b -> R b c -> R a c) -> Transitive R
  compositionalI :
    {A : Set} -> (R : A -> A -> Set)
    -> ({a b c : A} -> R b c -> R a b -> R a c) -> Transitive R
  compositionalI {A} R f =
    transitiveI (\{a b c : A} -> \(x : R a b) -> \(y : R b c) -> f y x)
  data Substitutive {A : Set} (R : A -> A -> Set) : Set1 where
    substitutiveI : ((P : A -> Set) -> {a b : A} -> R a b -> P a -> P b)
                   -> Substitutive R
  data Collapsed (A : Set) : Set1 where
    collapsedI : ((P : A -> Set) -> {a b : A} -> P a -> P b) -> Collapsed A

  cmp : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C
  cmp f g a = f (g a)
  seq : {A B C : Set} -> (A -> B) -> (B -> C) -> A -> C
  seq f g = cmp g f

  S : {A B C : Set} -> (C -> B -> A) -> (C -> B) -> C -> A
  S x y z = x z (y z)
  K : {A B : Set} -> A -> B -> A
  K x y = x
  I : {A : Set} -> A -> A
  I a = a
  -- of course I = S K K

  id = \{A : Set} -> I {A}

  const = \{A B : Set} -> K {A}{B}

  -- Set version
  pS : {P Q R : Set} -> (R -> Q -> P) -> (R -> Q) -> R -> P
  pS x y z = x z (y z)
  pK : {P Q : Set} -> P -> Q -> P
  pK x y = x
  pI : {P : Set} -> P -> P
  pI a = a

  proj : {A : Set} -> (B : A -> Set) -> (a : A) -> (f : (aa : A) -> B aa) -> B a
  proj B a f = f a

  flip : {A B C : Set} (f : A -> B -> C) (b : B) (a : A) -> C
  flip f b a = f a b

  -- separate definition of FlipRel is necessary because it is not the case
  -- that Set : Set.
  FlipRel : {A : Set} -> (R : A -> A -> Set) -> (a b : A) -> Set
  FlipRel R a b = R b a

  ----------------------------------------------------------------------------
  -- Product sets.
  ----------------------------------------------------------------------------
--  Prod : (A : Set) -> (A -> Set) -> Set
--  Prod A B = (a : A) -> B a
--  The above is not type-correct since (a : A) -> B a is not well-formed
--  but the following works.
  data Prod (A : Set) (B : A -> Set) : Set where
    prodI : ((a : A) -> B a) -> Prod A B
  mapProd : {A : Set} -> {B C : A -> Set} -> ((a : A) -> B a -> C a)
           -> Prod A B -> Prod A C
  mapProd {A} f (prodI g) = prodI (\(a : A) -> f a (g a))

--  data Fun (A B : Set) : Set1 where
--    funI : (A -> B) -> Fun A B
  Fun : Set -> Set -> Set
  Fun A B = Prod A (\(_ : A) -> B)

  mapFun : {A B C D : Set} -> (B -> A) -> (C -> D) -> (A -> C) -> B -> D
  mapFun {A} {B} {C} {D} f g h x = g (h (f x))
--  mapFun (|X1 |X2 |Y1 |Y2 :: Set)
--    :: (X2 -> X1) -> (Y1 -> Y2) -> (X1 -> Y1) -> X2 -> Y2
--    = \f -> \g -> \h -> \x ->
--      g (h (f x))

---------------------------------------------------------------------------
-- Identity proof sets.
---------------------------------------------------------------------------
-- to accept the following definition more general scheme of
-- inductive definition is required
--  data Id (A : Set) (a b : A) : Set1 where
--    ref : (a : A) -> Id A a a
--
--  elimId (|X :: Set)
--         (C :: (x1 x2 :: X)  |-> Id x1 x2 -> Set)
--         (refC :: (x :: X) -> C (refId x))
--         (|x1 |x2 :: X)
--         (u :: Id x1 x2) ::
--         C u
--    = case u of { (ref x) -> refC x;}
--
--  abstract whenId (|X :: Set)(C :: Rel X)(c :: (x :: X) -> C x x)
--    :: (x1 x2 :: X)  |-> Id x1 x2 -> C x1 x2
--    = elimId (\x1 x2 |-> \(u :: Id x1 x2) -> C x1 x2) c
--
--  abstract substId (|X :: Set) :: Substitutive Id
--    = \(C :: Pred X) ->
--      whenId (\x1 x2 -> C x1 -> C x2) (\x -> id)
--
--  abstract mapId (|X :: Set)(|Y :: Set)(f :: X -> Y)
--    :: (x1 x2 :: X) |-> Id x1 x2 -> Id (f x1) (f x2)
--    = whenId (\x1 x2 -> Id (f x1) (f x2)) (\(x :: X) -> refId (f x))
--
--  abstract symId (|X :: Set) :: Symmetrical Id
--    =  whenId (\(x1 x2 :: X) ->  Id x2 x1) refId
--
--  abstract cmpId (|X :: Set) :: Compositional Id
--    = let lem :: (x y :: X) |-> Id x y -> (z :: X) |-> Id z x -> Id z y
--            = whenId ( \(x y :: _) -> (z :: X) |-> Id z x -> Id z y)
--                     ( \x -> \z |-> id)
--      in  \(x1 x2 x3 :: _) |->
--          \(u :: Id x2 x3) ->
--          \(v :: Id x1 x2) ->
--          lem  u v
--
--  abstract tranId (|X :: Set) :: Transitive  Id
--    = \(x1 x2 x3 :: X) |->
--      \(u :: Id x1 x2) ->
--      \(v :: Id x2 x3) ->
--      cmpId v u

  ----------------------------------------------------------------------------
  -- The empty set.
  ----------------------------------------------------------------------------
  data Zero : Set where
--  --abstract whenZero (X :: Set)(z :: Zero) :: X
--  --  = case z of { }
--  do not know how to encode whenZero;  the following does not work.
--  whenZero : (X : Set) -> (z : Zero) -> X
--  whenZero X z =
--  --elimZero (C :: Zero -> Set)(z :: Zero) :: C z
--  --  = case z of { }
--  elimZero either!
--  elimZero : (C : Zero -> Set) -> (z : Zero) -> C z
--  elimZero C z =
--
--  abstract collZero :: Collapsed Zero
--    = \(C :: Zero -> Set) ->
--      \(z1 z2 :: Zero) |->
--      \(c :: C z1) ->
--      case z1 of { }
--
----------------------------------------------------------------------------
-- The singleton set.
----------------------------------------------------------------------------
  data Unit : Set where
    uu : Unit
  elUnit = uu
  elimUnit : (C : Unit -> Set) -> C uu -> (u : Unit) -> C u
  elimUnit C c uu = c
--  Do not know of the exact use of Collapse!
--  collUnit : (C : Unit -> Set) -> {u1  u2 : Unit} -> C u1 -> Collapsed Unit
--  collUnit C {uu} {uu} A = collapsedI (\(P : Unit -> Set) -> \{a b : Unit} -> \(y : P a) -> A)
--  abstract collUnit :: Collapsed Unit
--    = \(C :: Unit -> Set) ->
--      \(u1 u2 :: Unit) |->
--      \(c :: C u1) ->
--      case u1 of { (tt) -> case u2 of { (tt) -> c;};}
---------------------------------------------------------------------------
-- The successor set adds a new element.
---------------------------------------------------------------------------

  data Succ (A : Set) : Set where
    zerS : Succ A
    sucS : A -> Succ A
  zerSucc = \{A : Set} -> zerS {A}
  sucSucc = \{A : Set} -> sucS {A}
  elimSucc : {X : Set} -> (C : Succ X -> Set)
            -> C zerS -> ((x : X) -> C (sucS x)) -> (xx : Succ X) -> (C xx)
  elimSucc C c_z c_s zerS = c_z
  elimSucc C c_z c_s (sucS x) = c_s x
  whenSucc : {X Y : Set} -> Y -> (X -> Y) -> (Succ X) -> Y
  whenSucc y_z y_s zerS = y_z
  whenSucc y_z y_s (sucS x) = y_s x
  mapSucc : {X Y : Set} -> (X -> Y) -> Succ X -> Succ Y
  mapSucc {X} {_} f
    = whenSucc zerS (\(x : X) -> sucS (f x))

---------------------------------------------------------------------------
-- The (binary) disjoint union.
---------------------------------------------------------------------------

  data Plus (A B : Set) : Set where
    inl : A -> Plus A B
    inr : B -> Plus A B
  elimPlus : {X Y : Set} ->
            (C : Plus X Y -> Set) ->
            ((x : X) -> C (inl x)) ->
            ((y : Y) -> C (inr y)) ->
            (z : Plus X Y) ->
            C z
  elimPlus {X} {Y} C c_lft c_rgt (inl x) = c_lft x
  elimPlus {X} {Y} C c_lft c_rgt (inr x) = c_rgt x
  when : {X Y Z : Set} -> (X -> Z) -> (Y -> Z) -> Plus X Y -> Z
  when {X} {Y} {Z} f g (inl x) = f x
  when {X} {Y} {Z} f g (inr y) = g y
  whenplus : {X Y Z : Set} -> (X -> Z) -> (Y -> Z) -> Plus X Y -> Z
  whenplus = when
  mapPlus : {X1 X2 Y1 Y2 : Set} -> (X1 -> X2) -> (Y1 -> Y2)
           -> Plus X1 Y1 -> Plus X2 Y2
  mapPlus f g = when (\x1 -> inl (f x1)) (\y1 -> inr (g y1))
  swapPlus : {X Y : Set} -> Plus X Y -> Plus Y X
  swapPlus = when inr inl

----------------------------------------------------------------------------
-- Dependent pairs.
----------------------------------------------------------------------------

  data Sum (A : Set) (B : A -> Set) : Set where
    sumI : (fst : A) -> B fst -> Sum A B
  depPair : {A : Set} -> {B : A -> Set} -> (a : A) -> B a -> Sum A B
  depPair a b = sumI a b
  depFst : {A : Set} -> {B : A -> Set} -> (c : Sum A B) -> A
  depFst (sumI fst snd) = fst
  depSnd : {A : Set} -> {B : A -> Set} -> (c : Sum A B) -> B (depFst c)
  depSnd (sumI fst snd) = snd
  depCur : {A : Set} -> {B : A -> Set} -> {C : Set} -> (f : Sum A B -> C)
           -> (a : A) -> B a -> C
  depCur f = \a -> \b -> f (depPair a b)
  -- the above works but the below does not---why?
  -- depCur : {X : Set} -> {Y : X -> Set} -> {Z : Set} -> (f : Sum X Y -> Z)
  --         -> {x : X} -> Y x -> Z
  -- depCur {X} {Y} {Z} f = \{x} -> \y ->  f (depPair  x  y)
  -- Error message :
  -- When checking that the expression \{x} -> \y -> f (depPair x y)
  -- has type Y _x -> Z
  -- found an implicit lambda where an explicit lambda was expected
  depUncur : {A : Set} -> {B : A -> Set} -> {C : Set}
    -> ((a : A) -> B a -> C) -> Sum A B -> C
  depUncur f ab = f (depFst ab) (depSnd ab)
  depCurry : {A : Set} ->
             {B : A -> Set} ->
             {C : Sum A B -> Set} ->
             (f : (ab : Sum A B) -> C ab) ->
             (a : A) ->
             (b : B a) ->
             C (depPair a b)
  depCurry f a b = f (depPair a b)
  depUncurry : {A : Set} ->
               {B : A -> Set} ->
               {C : Sum A B -> Set} ->
               (f : (a : A) -> (b : B a) -> C (depPair a b)) ->
               (ab : Sum A B) ->
               C ab
  depUncurry f (sumI fst snd) = f fst snd
  mapSum : {A : Set} -> {B1 : A -> Set} -> {B2 : A -> Set}
          -> (f : (a : A) -> B1 a -> B2 a)
          -> Sum A B1 -> Sum A B2
  mapSum f (sumI fst snd) = depPair fst (f fst snd)
  elimSum = \{A : Set}{B : A -> Set}{C : Sum A B -> Set} -> depUncurry{A}{B}{C}
---------------------------------------------------------------------------
-- Nondependent pairs (binary) cartesian product.
---------------------------------------------------------------------------
  Times : Set -> Set -> Set
  Times A B = Sum A (\(_ : A) -> B)
  pair : {A : Set} -> {B : Set} -> A -> B -> Times A B
  pair a b = sumI a b
  fst : {A : Set} -> {B : Set} -> Times A B -> A
  fst (sumI a _) = a
  snd : {A : Set} -> {B : Set} -> Times A B -> B
  snd (sumI _ b) = b
  pairfun : {C : Set} -> {A : Set} -> {B : Set}
           -> (C -> A) -> (C -> B) -> C -> Times A B
  pairfun f g c = pair (f c) (g c)
  mapTimes : {A1 : Set} -> {A2 : Set} -> {B1 : Set} -> {B2 : Set}
            -> (A1 -> A2) -> (B1 -> B2) -> Times A1 B1 -> Times A2 B2
  mapTimes f g (sumI a b) = pair (f a) (g b)
  swapTimes : {A : Set} -> {B : Set} -> Times A B -> Times B A
  swapTimes (sumI a b) = sumI b a
  cur : {A : Set} -> {B : Set} -> {C : Set} -> (f : Times A B -> C) -> A -> B -> C
  cur f a b = f (pair a b)
  uncur : {A : Set} -> {B : Set} -> {C : Set} -> (A -> B -> C) -> Times A B -> C
  uncur f (sumI a b) = f a b
  curry : {A : Set} -> {B : Set} -> {C : Times A B -> Set}
         -> ((p : Times A B) -> C p) -> (a : A) ->(b : B) -> C (pair a b)
  curry f a b = f (pair a b)
  uncurry : {A : Set} -> {B : Set} -> {C : Times A B -> Set}
           -> ((a : A) -> (b : B) -> C (pair a b)) -> (p : Times A B) -> C p
  uncurry f (sumI a b) = f a b
  elimTimes = \{A B : Set}{C : Times A B -> Set} -> uncurry{A}{B}{C}
  ---------------------------------------------------------------------------
  -- Natural numbers.
  ---------------------------------------------------------------------------
  data Nat : Set where
    zero : Nat
    succ : Nat -> Nat
  elimNat : (C : Nat -> Set)
           -> (C zero) -> ((m : Nat) -> C m -> C (succ m)) -> (n : Nat) -> C n
  elimNat C c_z c_s zero = c_z
  elimNat C c_z c_s (succ m') = c_s m' (elimNat C c_z c_s m')

  ----------------------------------------------------------------------------
  -- Linear universe of finite sets.
  ----------------------------------------------------------------------------
  Fin : (m : Nat) -> Set
  Fin zero = Zero
  Fin (succ n) = Succ (Fin n)
{-
  Fin 0 = {}
  Fin 1 = { zerS }
  Fin 2 = { zerS (sucS zerS) }
  Fin 3 = { zerS (sucS zerS) (sucS (sucS zerS)) }
-}
  valFin : (n' : Nat) -> Fin n' -> Nat
  valFin zero     ()
  valFin (succ n) zerS = zero
  valFin (succ n) (sucS x) = succ (valFin n x)
  zeroFin : (n : Nat) -> Fin (succ n)
  zeroFin n = zerS
  succFin : (n : Nat) -> Fin n -> Fin (succ n)
  succFin n N = sucS N
  ----------------------------------------------------------------------------
  -- Do these really belong here?
  ----------------------------------------------------------------------------
  HEAD : {A : Set} -> (n : Nat) -> (Fin (succ n) -> A) -> A
  HEAD n f = f (zeroFin n)
  TAIL : {A : Set} -> (n : Nat) -> (Fin (succ n) -> A) -> Fin n -> A
  TAIL n f N = f (succFin n N)
  ----------------------------------------------------------------------------
  -- Lists.
  ----------------------------------------------------------------------------
  data List (A : Set) : Set where
    nil : List A
    con : A -> List A -> List A
  elimList : {A : Set} ->
            (C : List A -> Set) ->
            (C nil) ->
            ((a : A) -> (as : List A) -> C as -> C (con a as)) ->
            (as : List A) ->
            C as
  elimList _ c_nil _ nil = c_nil
  elimList C c_nil c_con (con a as) = c_con a as (elimList C c_nil c_con as)
  ----------------------------------------------------------------------------
  -- Tuples are "dependently typed vectors".
  ----------------------------------------------------------------------------
  data Nill : Set where
    nill : Nill
  data Cons (A B : Set) : Set where
    cons : A -> B -> Cons A B
  Tuple : (n : Nat) -> (C : Fin n -> Set) -> Set
  Tuple zero = \ C -> Nill
  Tuple (succ n) = \ C -> Cons (C zerS) (Tuple n (\(N : Fin n) -> C (sucS N)))
  ----------------------------------------------------------------------------
  -- Vectors homogeneously typed tuples.
  ----------------------------------------------------------------------------
  Vec : Set -> Nat -> Set
  Vec A m = Tuple m (\(n : Fin m) -> A)
  ----------------------------------------------------------------------------
  -- Monoidal expressions.
  ----------------------------------------------------------------------------
  data Mon (A : Set) : Set where
    unit : Mon A
    at : A -> Mon A
    mul : Mon A -> Mon A -> Mon A
{-
-}

----------------------------------------------------------------------------
-- Propositions.
----------------------------------------------------------------------------
  data Implies (A B : Set) : Set where
    impliesI : (A -> B) -> Implies A B
  data Absurd : Set where
  data Taut : Set where
    tt : Taut
  data Not (P : Set) : Set where
    notI : (P -> Absurd) -> Not P
  -- encoding of Exists is unsatisfactory!  Its type should be Set.
  data Exists (A : Set) (P : A -> Set) : Set where
    existsI : (evidence : A) -> P evidence -> Exists A P
  data Forall (A : Set) (P : A -> Set) : Set where
    forallI : ((a : A) -> P a) -> Forall A P
  data And (A B : Set) : Set where
    andI : A -> B -> And A B
  Iff : Set -> Set -> Set
  Iff A B = And (Implies A B) (Implies B A)
  data Or (A B : Set) : Set where
    orIl : (a : A) -> Or A B
    orIr : (b : B) -> Or A B
  Decidable : Set -> Set
  Decidable P = Or P (Implies P Absurd)
  data DecidablePred {A : Set} (P : A -> Set) : Set where
   decidablepredIl : (a : A) -> (P a) -> DecidablePred P
   decidablepredIr : (a : A) -> (Implies (P a) Absurd) -> DecidablePred P
  data DecidableRel {A : Set} (R : A -> A -> Set) : Set where
   decidablerelIl : (a b : A) -> (R a b) -> DecidableRel R
   decidablerelIr : (a b : A) -> (Implies (R a b) Absurd) -> DecidableRel R
  data Least {A : Set} (_<=_ : A -> A -> Set) (P : A -> Set) (a : A) : Set where
    leastI : (P a) -> ((aa : A) -> P aa -> (a <= aa)) -> Least _<=_ P a
  data Greatest {A : Set} (_<=_ : A -> A -> Set) (P : A -> Set) (a : A) : Set where
    greatestI : (P a) -> ((aa : A) -> P aa -> (aa <= a)) -> Greatest _<=_ P a

----------------------------------------------------------------------------
-- Booleans.
----------------------------------------------------------------------------
  data Bool : Set where
    true : Bool
    false : Bool
  elimBool : (C : Bool -> Set) -> C true -> C false -> (b : Bool) -> C b
  elimBool C c_t c_f true = c_t
  elimBool C c_t c_f false = c_f
  whenBool : (C : Set) -> C -> C -> Bool -> C
  whenBool C c_t c_f b = elimBool (\(_ : Bool) -> C) c_t c_f b
  data pred (A : Set) : Set where
    predI : (A -> Bool) -> pred A
  data rel (A : Set) : Set where
    relI : (A -> A -> Bool) -> rel A
  True : Bool -> Set
  True true = Taut
  True false = Absurd
  bool2set = True
  pred2Pred : {A : Set} -> pred A -> Pred A
  pred2Pred (predI p) = PredI (\a -> True (p a))
  rel2Rel : {A : Set} -> rel A -> Rel A
  rel2Rel (relI r) = RelI (\a -> \b -> True (r a b))
--  decTrue : (p : Bool) -> Decidable (True p)
--  decTrue true = orIl tt
--  decTrue false = orIr (impliesI pI)
-- decTrue false = orIr (impliesI (\(p : (True false)) -> p))
--  dec_lem : {P : Set} -> (decP : Decidable P)
--           -> Exists A
{-
  abstract dec_lem (|P :: Set)(decP :: Decidable P)
    :: Exist |_ (\(b :: Bool) -> Iff (True b) P)
    = case decP of {
        (inl trueP) ->
          struct {
            fst = true@_;
            snd =
              struct {
                fst = const |_  |_ trueP;  -- (True true@_)
                snd = const |_ |_  tt;};};
        (inr notP) ->
          struct {
            fst = false@_;
            snd =
              struct {
                fst = whenZero P;
                snd = notP;};};}
  dec2bool :: (P :: Set) |-> (decP :: Decidable P) -> Bool
    = \(P :: Set) |-> \(decP :: Decidable P) -> (dec_lem |_ decP).fst
  dec2bool_spec (|P :: Set)(decP :: Decidable P)
    :: Iff (True (dec2bool |_ decP)) P
    = (dec_lem |_ decP).snd

  abstract collTrue :: (b :: Bool) -> Collapsed (True b)
    = let aux (X :: Set)(C :: X -> Set)
            :: (b :: Bool) ->
               (f :: True b -> X) ->
               (t1 :: True b) |->
               (t2 :: True b) |->
               C (f t1) -> C (f t2)
            = \(b :: Bool) ->
              case b of {
                (true) ->
                  \(f :: (x :: True true@_) -> X) ->
                  \(t1 t2 :: True true@_) |->
                  \(c :: C (f t1)) ->
                  case t1 of { (tt) -> case t2 of { (tt) -> c;};};
                (false) ->
                  \(f :: (x :: True false@_) -> X) ->
                  \(t1 t2 :: True false@_) |->
                  \(c :: C (f t1)) ->
                  case t1 of { };}
      in   \(b :: Bool) ->  \(P :: True b -> Set) -> aux (True b) P b id

  bool2nat (p :: Bool) :: Nat
    = case p of {
        (true) -> succ zero;
        (false) -> zero;}
-}


module BuildingBlock.BinaryLeafTree where

open import Function
open import Data.Nat
open import Data.Nat.Etc
open import Data.Nat.Properties.Simple using (+-right-identity)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Fin
    using (Fin; toℕ; fromℕ; fromℕ≤; reduce≥)
    renaming (zero to Fzero; suc to Fsuc)

open import Data.Empty

open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; trans; sym; inspect)
open PropEq.≡-Reasoning
--------------------------------------------------------------------------------
-- Complete Binary Leaf Trees

data BinaryLeafTree (A : Set) : ℕ → Set where
    Leaf : A → BinaryLeafTree A 0
    Node : ∀ {n} → BinaryLeafTree A n
                 → BinaryLeafTree A n
                 → BinaryLeafTree A (suc n)

-- splits a BinaryLeafTree into 2
split : ∀ {A n} → BinaryLeafTree A (suc n)
                → BinaryLeafTree A n × BinaryLeafTree A n
split (Node xs ys) = xs , ys

-- merge 2 BinaryLeafTree
merge : ∀ {A n} → BinaryLeafTree A n
                → BinaryLeafTree A n
                → BinaryLeafTree A (suc n)
merge = Node

split-merge : ∀ {n A} → (xs : BinaryLeafTree A (suc n))
            → merge (proj₁ (split xs)) (proj₂ (split xs)) ≡ xs
split-merge (Node xs ys) = refl

-- get the first element
head : ∀ {A n} → BinaryLeafTree A n → A
head (Leaf x) = x
head (Node xs ys) = head xs

-- searching
transportFin : ∀ {a b} → a ≡ b → Fin a → Fin b
transportFin refl i = i

¬a≤b⇒b<a : ∀ {a b} → ¬ (a ≤ b) → b < a
¬a≤b⇒b<a {zero } {b    } p = ⊥-elim (p z≤n)
¬a≤b⇒b<a {suc a} {zero } p = s≤s z≤n
¬a≤b⇒b<a {suc a} {suc b} p = s≤s (¬a≤b⇒b<a (λ z → p (s≤s z)))

elemAt : ∀ {A n} → BinaryLeafTree A n → Fin (2 ^ n) → A
elemAt {n = zero}  (Leaf x)     Fzero = x
elemAt {n = zero}  (Leaf x)     (Fsuc ())
elemAt {n = suc n} (Node xs ys) i with (2 ^ n) ≤? toℕ i
elemAt {n = suc n} (Node xs ys) i | yes p = elemAt ys (transportFin (+-right-identity (2 ^ n)) (reduce≥ {2 ^ n} {2 ^ n + 0} i p))
elemAt {n = suc n} (Node xs ys) i | no ¬p = elemAt xs (fromℕ≤ (¬a≤b⇒b<a ¬p))

-- examples
private
    fier : BinaryLeafTree ℕ 2
    fier = Node
            (Node
                (Leaf 0)
                (Leaf 2))
            (Node
                (Leaf 3)
                (Leaf 1))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Examples showing how the notion of Interleaving can be used
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module README.Data.Interleaving where

open import Level
open import Data.List.Base hiding (filter)
open import Data.List.Relation.Unary.All
open import Function
open import Relation.Nullary
open import Relation.Unary

-- In its most general form, `Interleaving` is parametrised by two relations
-- `L` (for Left) and `R` (for Right). Given three lists, `xs`, `ys` and `zs`,
-- a proof of `Interleaving xs ys zs` is essentially a diagram explaining how
-- `zs` can be pulled apart into `xs` and `ys` in a way compatible with `L`
-- and `R`. For instance:

-- xs               zs               ys
--
-- x₁ -- L x₁ z₁ -- z₁
-- x₂ -- L x₂ z₂ -- z₂
--                  z₃ -- R z₃ z₁ -- y₁
-- x₃ -- L x₃ z₄ -- z₄
--                  z₅ -- R z₅ y₂ -- y₂

open import Data.List.Relation.Ternary.Interleaving.Propositional

-- The special case we will focus on here is the propositional case: both
-- `L` and ̀R` are propositional equality. Rethinking our previous example,
-- this gives us the proof that [z₁, ⋯, z₅] can be partitioned into
-- [z₁, z₂, z₄] on the one hand and [z₃, z₅] in the other.

-- One possible use case for such a relation is the definition of a very
-- precise filter function. Provided a decidable predicate `P`, it will
-- prove not only that the retained values satisfy `P` but that the ones
-- that didn't make the cut satisfy the negation of P.

-- We can make this formal by defining the following record type:

infix 3 _≡_⊎_
record Filter {a p} {A : Set a} (P : Pred A p) (xs : List A) : Set (a ⊔ p) where
  constructor _≡_⊎_
  field
    -- The result of running filter is two lists:
    -- * the elements we have kept
    -- * and the ones we have thrown away
    -- We leave these implicit: they can be inferred from the rest
    {kept}   : List A
    {thrown} : List A
    -- There is a way for us to recover the original
    -- input by interleaving the two lists
    cover    : Interleaving kept thrown xs
    -- Finally, the partition was made according to the predicate
    allP     : All P kept
    all¬P    : All (∁ P) thrown

-- Once we have this type written down, we can write the function.
-- We use an anonymous module to clean up the function's type.

module _ {a p} {A : Set a} {P : Pred A p} (P? : Decidable P) where

  filter : ∀ xs → Filter P xs
  -- If the list is empty, we are done.
  filter []       = [] ≡ [] ⊎ []
  filter (x ∷ xs) =
    -- otherwise we start by running filter on the tail
    let xs' ≡ ps ⊎ ¬ps = filter xs in
    -- And depending on whether `P` holds of the head,
    -- we cons it to the `kept` or `thrown` list.
    case P? x of λ where -- [1]
      (yes p) → consˡ xs' ≡ p ∷ ps ⊎      ¬ps
      (no ¬p) → consʳ xs' ≡     ps ⊎ ¬p ∷ ¬ps

-- [1] See the following module for explanations of `case_of_` and
--     pattern-matching lambdas
import README.Case


------------------------------------------------------------------------
-- The Agda standard library
--
-- Induced preorders
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.InducedPreorders
         {s₁ s₂}
         (S : Setoid s₁ s₂)  -- The underlying equality.
         where

open import Function
open import Data.Product

open Setoid S

-- Every respectful unary relation induces a preorder. (No claim is
-- made that this preorder is unique.)

InducedPreorder₁ : ∀ {p} (P : Carrier → Set p) →
                   P Respects _≈_ → Preorder _ _ _
InducedPreorder₁ P resp = record
  { _≈_        = _≈_
  ; _∼_        = λ c₁ c₂ → P c₁ → P c₂
  ; isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive     = resp
    ; trans         = flip _∘′_
    }
  }

-- Every respectful binary relation induces a preorder. (No claim is
-- made that this preorder is unique.)

InducedPreorder₂ : ∀ {a r} {A : Set a} →
                   (_R_ : A → Carrier → Set r) →
                   (∀ {x} → _R_ x Respects _≈_) → Preorder _ _ _
InducedPreorder₂ _R_ resp = record
  { _≈_        = _≈_
  ; _∼_        = λ c₁ c₂ → ∀ {a} → a R c₁ → a R c₂
  ; isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive     = λ c₁≈c₂ → resp c₁≈c₂
    ; trans         = λ c₁∼c₂ c₂∼c₃ → c₂∼c₃ ∘ c₁∼c₂
    }
  }


{-# OPTIONS --without-K --safe #-}

open import Categories.Category.Core

-- Kernel Pair - a Pullback of a morphism along itself
-- https://ncatlab.org/nlab/show/kernel+pair
module Categories.Diagram.KernelPair {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open import Categories.Diagram.Pullback 𝒞

open Category 𝒞

private
  variable
    A B : Obj

-- Make it a pure synonym
KernelPair : (f : A ⇒ B) → Set (o ⊔ ℓ ⊔ e)
KernelPair f = Pullback f f


------------------------------------------------------------------------------
-- Well-founded relation on lists
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.List.WellFoundedRelationsSL {A : Set} where

open import Data.Product
open import Data.List hiding ( length )
open import Data.Nat

open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------------
-- We use our own version of the function length because we have
-- better reductions.
length : List A → ℕ
length []       = 0
length (x ∷ xs) = 1 + length xs

open module II = Induction.WellFounded.Inverse-image {_<_ = _<′_} length

-- Well-founded relation on lists based on their length.
LTL : List A → List A → Set
LTL xs ys = length xs <′ length ys

-- The relation LTL is well-founded (using the image inverse
-- combinator).
wfLTL : Well-founded LTL
wfLTL = II.well-founded <′-well-founded

-- Well-founded relation on lists based on their structure.
LTC : List A → List A → Set
LTC xs ys = Σ A (λ a → ys ≡ a ∷ xs)

LTC→LTL : ∀ {xs ys} → LTC xs ys → LTL xs ys
LTC→LTL (x , refl) = ≤′-refl

open module S = Induction.WellFounded.Subrelation {_<₁_ = LTC} LTC→LTL

-- The relation LTC is well-founded (using the subrelation combinator).
wfLTC : Well-founded LTC
wfLTC = S.well-founded wfLTL


module RecordPatternMatching where

-- Sigma type.

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ

_×_ : Set → Set → Set
A × B = Σ A λ _ → B

-- Curry and uncurry with pattern matching.

curry : ∀ {A : Set} {B : A → Set} {C : Σ A B → Set} →
        ((p : Σ A B) → C p) →
        ((x : A) → (y : B x) → C (x , y))
curry f x y = f (x , y)

uncurry : ∀ {A : Set} {B : A → Set} {C : Σ A B → Set} →
          ((x : A) → (y : B x) → C (x , y)) →
          ((p : Σ A B) → C p)
uncurry f (x , y) = f x y

-- We still have η-equality.

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

curry∘uncurry : ∀ {A : Set} {B : A → Set} {C : Σ A B → Set} →
                (f : (x : A) → (y : B x) → C (x , y)) →
                (x : A) → (y : B x) →
                curry {C = C} (uncurry f) x y ≡ f x y
curry∘uncurry f x y = refl

uncurry∘curry : ∀ {A : Set} {B : A → Set} {C : Σ A B → Set} →
                (f : (p : Σ A B) → C p) →
                (p : Σ A B) →
                uncurry {C = C} (curry f) p ≡ f p
uncurry∘curry f p = refl

-- Nested pattern matching is also possible.

to : {A B C : Set} → A × (B × C) → (A × B) × C
to (x , (y , z)) = ((x , y) , z)

from : {A B C : Set} → (A × B) × C → A × (B × C)
from ((x , y) , z) = (x , (y , z))

from∘to : {A B C : Set} (p : A × (B × C)) → from (to p) ≡ p
from∘to p = refl

data Bool : Set where
  true false : Bool

data ⊥ : Set where

F : Bool → Set
F true  = Bool
F false = ⊥

foo : Σ Bool F → Bool
foo (true  , b)  = b
foo (false , ())

bar : ∀ p → F (foo p) → F (foo p)
bar (true  , true)  = λ b → b
bar (true  , false) = λ ()
bar (false , ())

baz : (Σ Bool λ _ → Σ Bool λ _ → Bool) → Bool
baz (true  , (b , c)) = b
baz (false , (b , c)) = c

lemma : ∀ p → baz (false , p) ≡ proj₂ p
lemma p = refl

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

add : ℕ × ℕ → ℕ
add (zero  , n) = n
add (suc m , n) = suc (add (m , n))

-- The code below used to trigger a bug: in one part of the code B was
-- assumed to be reduced to an application of a record type
-- constructor.

data Unit : Set where
  unit : Unit

B : Set
B = Σ Unit λ _ → Unit

C : B → Set₁
C (_ , _) = Set

-- The code below, which involves a clause with a "swapping
-- permutation", also used to trigger a bug.

data P : ⊥ → ⊥ → Set where
  p : (x y : ⊥) → P x y

Bar : (x : ⊥) → P x x → P x x → Set₁
Bar .x _ (p x .x) = Set

-- Another example which used to trigger a bug:

G : (Σ ⊥ λ x → Σ ⊥ λ y → x ≡ y) → Set₁
G (x , (.x , refl)) = Set

-- Record patterns containing dot patterns are supported.

Foo : (p₁ p₂ : B) → proj₁ p₁ ≡ proj₁ p₂ → Unit
Foo (x , y) (.x , y′) refl = unit

Foo-eval : (p : B) → Foo p p refl ≡ unit
Foo-eval _ = refl

-- Record patterns containing dot patterns as well as data type
-- patterns are also supported.

D : (p₁ p₂ : B) → proj₁ p₁ ≡ proj₁ p₂ → Set₁
D (x , y) (.x , unit) refl = Set


module Data.Finitude where

open import Data.Fin as Fin
open import Data.Nat as ℕ
open import Level

open import Function as Fun hiding (id; _∘_)
open import Function.Equality as F using (_⟨$⟩_)
open import Function.Injection as Inj hiding (id; _∘_)
open import Function.Bijection as Bij hiding (id; _∘_)
open import Function.LeftInverse      hiding (id; _∘_)
open import Function.Inverse   as Inv hiding (id; _∘_)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as P
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_)

Finitude : ∀ {a ℓ} (A : Setoid a ℓ) (n : ℕ) → Set _
Finitude A n = Inverse A (P.setoid (Fin n))

module Subset where
  open import Data.Product as Prod hiding (map)
  open import Data.Fin.Subset using (Subset; _∈_; outside; inside; ∣_∣) renaming (⊥ to ∅)
  open import Data.Vec
  subset-finitude : ∀ {n}(s : Subset n) → Finitude (P.setoid (∃ (_∈ s))) ∣ s ∣
  subset-finitude {ℕ.zero} [] = record {
      to = P.→-to-⟶ (λ ())
    ; from = P.→-to-⟶ (λ () )
    ; inverse-of = record {
        left-inverse-of = λ ()
      ; right-inverse-of = λ ()
      }
    }
  subset-finitude {ℕ.suc n} (inside ∷ s) = record {
        to = P.→-to-⟶ λ { (_ , here) → Fin.zero
                          ; (_ , there p) → Fin.suc (to ⟨$⟩ (_ , p)) }
      ; from = P.→-to-⟶ λ { Fin.zero → _ , here
                           ; (Fin.suc i) → _ , there (proj₂ (from ⟨$⟩ i))}
      ; inverse-of = record {
            left-inverse-of = λ { (_ , here) → P.refl
                                 ; (_ , there p) → P.cong
                                   (Prod.map Fin.suc there) (linv (_ , p))}
          ; right-inverse-of = λ { Fin.zero → P.refl
                                 ; (Fin.suc i) → P.cong Fin.suc (rinv i)}
        }
      }
    where
      open Inverse (subset-finitude s)
      open _InverseOf_ inverse-of renaming (left-inverse-of to linv
                                           ;right-inverse-of to rinv)

  subset-finitude {ℕ.suc n} (outside ∷ s) = record {
      to = P.→-to-⟶ (λ { (_ , there p) → to ⟨$⟩ (_ , p)})
    ; from = P.→-to-⟶ (λ i → Prod.map Fin.suc there (from ⟨$⟩ i) )
    ; inverse-of = record {
           left-inverse-of = λ { (_ , there p) →
             P.cong (Prod.map Fin.suc there) (linv (_ , p)) }
         ; right-inverse-of = rinv
      }
    }
      where
        open Inverse (subset-finitude s)
        open _InverseOf_ inverse-of renaming ( left-inverse-of to linv
                                             ; right-inverse-of to rinv)


module Data.Boolean.NaryOperators where

open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Logic
open import Function.DomainRaise
open import Numeral.Natural

private variable n : ℕ

-- N-ary conjunction (AND).
-- Every term is true.
∧₊ : (n : ℕ) → (Bool →̂ Bool)(n)
∧₊(0) = 𝑇
∧₊(1) x = x
∧₊(𝐒(𝐒(n))) x = (x ∧_) ∘ (∧₊(𝐒(n)))

-- N-ary disjunction (OR).
-- There is a term which is true.
∨₊ : (n : ℕ) → (Bool →̂ Bool)(n)
∨₊(0) = 𝐹
∨₊(1) x = x
∨₊(𝐒(𝐒(n))) x = (x ∨_) ∘ (∨₊(𝐒(n)))

-- N-ary implication.
-- All left terms together imply the right-most term.
⟶₊ : (n : ℕ) → (Bool →̂ Bool)(n)
⟶₊(0) = 𝑇
⟶₊(1) x = x
⟶₊(𝐒(𝐒(n))) x = (x ⟶_) ∘ (⟶₊(𝐒(n)))

-- N-ary NAND.
-- Not every term is true.
-- There is a term which is false.
⊼₊ : (n : ℕ) → (Bool →̂ Bool)(n)
⊼₊(0) = 𝐹
⊼₊(1) x = ¬ x
⊼₊(𝐒(𝐒(n))) x = (x ⊼_) ∘ ((¬) ∘ (⊼₊(𝐒(n))))

-- N-ary NOR.
-- There are no terms that are true.
-- Every term is false.
⊽₊ : (n : ℕ) → (Bool →̂ Bool)(n)
⊽₊(0) = 𝐹
⊽₊(1) x = ¬ x
⊽₊(𝐒(𝐒(n))) x = (x ⊽_) ∘ ((¬) ∘ (⊽₊(𝐒(n))))


module #2 where

open import Data.Product
open import Data.Sum
open import Relation.Binary.PropositionalEquality

{-
Exercise 1.2. Derive the recursion principle for products recA×B using only the projections, and
verify that the definitional equalities are valid. Do the same for Σ-types.
-}

module Products { a b c }{A : Set a}{B : Set b}{C : Set c}(g : A → B → C) where

  recₓ :  A × B → C
  recₓ x = g (proj₁ x) (proj₂ x)

  rec-β : (x : A)(y : B) → recₓ (x , y) ≡ g x y
  rec-β x y = refl

module Sums { a b c }{A : Set a}{B : A → Set b}{C : Set c}(g : (x : A) → B x → C) where

  rec-Σ : Σ A B → C
  rec-Σ x = g (proj₁ x) (proj₂ x)

  rec-Σ-β : (x : A)(y : B x) → rec-Σ (x , y) ≡ g x y
  rec-Σ-β x y = refl


{-# OPTIONS --safe #-}
module Cubical.Algebra.Monoid.BigOp where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.SIP

open import Cubical.Data.Nat using (ℕ ; zero ; suc)
open import Cubical.Data.FinData

open import Cubical.Algebra.Monoid.Base

private
  variable
    ℓ ℓ' : Level

module MonoidBigOp (M' : Monoid ℓ) where
 private M = ⟨ M' ⟩
 open MonoidStr (snd M')

 bigOp : {n : ℕ} → FinVec M n → M
 bigOp = foldrFin _·_ ε

 bigOpExt : ∀ {n} {V W : FinVec M n} → ((i : Fin n) → V i ≡ W i) → bigOp V ≡ bigOp W
 bigOpExt h = cong bigOp (funExt h)

 bigOpε : ∀ n → bigOp (replicateFinVec n ε) ≡ ε
 bigOpε zero = refl
 bigOpε (suc n) = cong (ε ·_) (bigOpε n) ∙ ·IdR _

 bigOpLast : ∀ {n} (V : FinVec M (suc n)) → bigOp V ≡ bigOp (V ∘ weakenFin) · V (fromℕ n)
 bigOpLast {n = zero} V = ·IdR _ ∙ sym (·IdL _)
 bigOpLast {n = suc n} V = cong (V zero ·_) (bigOpLast (V ∘ suc)) ∙ ·Assoc _ _ _

 -- requires a commutative monoid:
 bigOpSplit : (∀ x y → x · y ≡ y · x)
            → {n : ℕ} → (V W : FinVec M n) → bigOp (λ i → V i · W i) ≡ bigOp V · bigOp W
 bigOpSplit _ {n = zero} _ _ = sym (·IdR _)
 bigOpSplit comm {n = suc n} V W =
    V zero · W zero · bigOp (λ i → V (suc i) · W (suc i))
  ≡⟨ (λ i → V zero · W zero · bigOpSplit comm (V ∘ suc) (W ∘ suc) i) ⟩
    V zero · W zero · (bigOp (V ∘ suc) · bigOp (W ∘ suc))
  ≡⟨ sym (·Assoc _ _ _) ⟩
    V zero · (W zero · (bigOp (V ∘ suc) · bigOp (W ∘ suc)))
  ≡⟨ cong (V zero ·_) (·Assoc _ _ _) ⟩
    V zero · ((W zero · bigOp (V ∘ suc)) · bigOp (W ∘ suc))
  ≡⟨ cong (λ x → V zero · (x · bigOp (W ∘ suc))) (comm _ _) ⟩
    V zero · ((bigOp (V ∘ suc) · W zero) · bigOp (W ∘ suc))
  ≡⟨ cong (V zero ·_) (sym (·Assoc _ _ _)) ⟩
    V zero · (bigOp (V ∘ suc) · (W zero · bigOp (W ∘ suc)))
  ≡⟨ ·Assoc _ _ _ ⟩
    V zero · bigOp (V ∘ suc) · (W zero · bigOp (W ∘ suc)) ∎

 bigOpSplit++ : (∀ x y → x · y ≡ y · x)
              → {n m : ℕ} → (V : FinVec M n) → (W : FinVec M m)
              → bigOp (V ++Fin W) ≡ bigOp V · bigOp W

 bigOpSplit++ comm {n = zero} V W = sym (·IdL _)
 bigOpSplit++ comm {n = suc n} V W = cong (V zero ·_) (bigOpSplit++ comm (V ∘ suc) W) ∙ ·Assoc _ _ _


module automaton where

open import Data.Nat
open import Data.List
open import Relation.Binary.PropositionalEquality hiding ( [_] )
open import logic

record Automaton ( Q : Set ) ( Σ : Set  )
       : Set  where
    field
        δ : Q → Σ → Q
        aend : Q → Bool

open Automaton

accept : { Q : Set } { Σ : Set  }
    → Automaton Q  Σ
    → Q
    → List  Σ → Bool
accept M q [] = aend M q
accept M q ( H  ∷ T ) = accept M ( δ M q H ) T

moves : { Q : Set } { Σ : Set  }
    → Automaton Q  Σ
    → Q → List  Σ → Q
moves M q [] = q
moves M q ( H  ∷ T ) = moves M ( δ M q H)  T

trace : { Q : Set } { Σ : Set  }
    → Automaton Q  Σ
    → Q → List  Σ → List Q
trace {Q} { Σ} M q [] = q ∷ []
trace {Q} { Σ} M q ( H  ∷ T ) = q ∷ trace M ( (δ M) q H ) T

reachable : { Q : Set } { Σ : Set  }
    → (M : Automaton Q  Σ  )
    → (astart q : Q )
    → (L : List  Σ ) → Set
reachable M astart q L = moves M astart  L ≡ q


{-# OPTIONS --sized-types #-}
module SBList {A : Set}(_≤_ : A → A → Set) where

open import Bound.Total A
open import Bound.Total.Order _≤_
open import Data.List
open import Data.Product
open import Size

data SBList : {ι : Size} → Bound → Bound → Set where
  nil : {ι : Size}{b t : Bound}
                   → LeB b t
                   → SBList {↑ ι} b t
  cons : {ι : Size}{b t : Bound}
                   (x : A)
                   → LeB b (val x)
                   → LeB (val x) t
                   → SBList {ι} b t
                   → SBList {↑ ι} b t

bound : List A → SBList bot top
bound [] = nil lebx
bound (x ∷ xs) = cons x lebx lext (bound xs)

unbound : {b t : Bound} → SBList b t → List A
unbound (nil _) = []
unbound (cons x _ _ xs) = x ∷ unbound xs

unbound× : {ι : Size}{b t b' t' : Bound} → SBList {ι} b t × SBList {ι} b' t' → List A × List A
unbound×  (xs , ys) = (unbound xs , unbound ys)


module Bush where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

{-# BUILTIN NATURAL Nat #-}

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

_^_ : (Set -> Set) -> Nat -> Set -> Set
(F ^ zero)  A = A
(F ^ suc n) A = F ((F ^ n) A)

data Bush (A : Set) : Set where
  leaf : Bush A
  node : A -> (Bush ^ 3) A -> Bush A

elim :
  (P : (A : Set) -> Bush A -> Set) ->
  ((A : Set) -> P A leaf) ->
  ((A : Set)(x : A)(b : (Bush ^ 3) A) ->
    P ((Bush ^ 2) A) b -> P A (node x b)) ->
  (A : Set)(b : Bush A) -> P A b
elim P l n A leaf       = l A
elim P l n A (node x b) = n A x b (elim P l n ((Bush ^ 2) A) b)

iter :
  (P : (A : Set) -> Set) ->
  ((A : Set) -> P A) ->
  ((A : Set) -> A -> P ((Bush ^ 2) A) -> P A) ->
  (A : Set) -> Bush A -> P A
iter P l n A leaf       = l A
iter P l n A (node x b) = n A x (iter P l n ((Bush ^ 2) A) b)

data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

_++_ : {A : Set} -> List A -> List A -> List A
[] ++ ys = ys
(x :: xs) ++ ys = x :: (xs ++ ys)

flatten : {A : Set}(n : Nat) -> (Bush ^ n) A -> List A
flatten zero    x          = x :: []
flatten (suc n) leaf       = []
flatten (suc n) (node x b) = flatten n x ++ flatten (3 + n) b

-- Andreas, 2017-01-01, issue #1899.
-- Normalize field types for positivity checking.
record B (A : Set) : Set where
  coinductive
  field f : (B ^ 3) A


open import Data.Nat
open import Data.Vec
open import Data.List

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

module DependentFold where

Nat = ℕ

dfold : ∀ {a : Set}
      → {k : Nat}
      → (p : Nat → Set)
      → ((l : Nat) → a → p l → p (1 + l))
      → p 0
      → Vec a k
      → p k
dfold {k = 0} p step base [] = base
dfold {k = suc n} p step base (x ∷ xs) = step n x (dfold p step base xs)

foldrₗ : {a b : Set} -> (a -> b -> b) -> b -> List a -> b
foldrₗ step base []       = base
foldrₗ step base (x ∷ xs) = step x (foldrₗ step base xs)

map_motive : Set -> Nat -> Set
map_motive a l = Vec a l

dmap : {a b : Set} → {n : ℕ} → (a → b) → Vec a n → Vec b n
dmap {a} {b} {n} f xs = dfold (map_motive b) (λ _ x xs → f x ∷ xs) [] xs

_ : dmap (λ x → x + 3) (1 ∷ 2 ∷ 3 ∷ []) ≡ (4 ∷ 5 ∷ 6 ∷ [])
_ = refl

dappend : {a : Set} → {m n : ℕ} → Vec a m → Vec a n → Vec a (m + n)
dappend {a} {m} {n} xs ys = dfold (λ l → Vec a (l + n)) (λ _ x xs → x ∷ xs) ys xs

_ : dappend (1 ∷ 2 ∷ []) (3 ∷ 4 ∷ []) ≡ 1 ∷ 2 ∷ 3 ∷ 4 ∷ []
_ = refl

ind : {a : Set} {p : List a → Set}
    → ((x : a) → {xs : List a} → p xs → p (x ∷ xs))
    → p []
    → (l : List a)
    → p l
ind step base [] = base
ind step base (x ∷ xs) = step x (ind step base xs)


-- Source: https://raw.githubusercontent.com/gallais/potpourri/master/agda/poc/dimensions/dimensions.agda
-- Author: Original by gallais, modified for test suite by P. Hausmann
-- (Later edited by others.)

{-# OPTIONS --guardedness #-}

module dimensions where

open import Data.Nat     as ℕ using (ℕ; NonZero)
open import Data.Nat.LCM
open import Data.Nat.DivMod hiding (_/_)
open import Data.Integer as ℤ using (ℤ ; +_)

open import Data.Unit.Polymorphic using (⊤)
open import Function
open import Relation.Nullary.Decidable

------------------------------------------------
-- DIMENSIONS
-- record { kilogram = x ; meter = y ; second = z }
-- corresponds to the dimension: kg^x * m^y * s^z

module Dimension where

  record dimension : Set where
    field
      kilogram : ℤ
      meter    : ℤ
      second   : ℤ
  open dimension public

  _*_ : (d e : dimension) → dimension
  d * e = record { kilogram = kilogram d ℤ.+ kilogram e
                 ; meter    = meter d    ℤ.+ meter e
                 ; second   = second d   ℤ.+ second e }

  _/_ : (d e : dimension) → dimension
  d / e = record { kilogram = kilogram d ℤ.- kilogram e
                 ; meter    = meter d    ℤ.- meter e
                 ; second   = second d   ℤ.- second e }

open Dimension using (dimension ; kilogram ; meter ; second)

kgram met sec : dimension
kgram = record { kilogram = + 1
               ; meter    = + 0
               ; second   = + 0 }
met   = record { kilogram = + 0
               ; meter    = + 1
               ; second   = + 0 }
sec   = record { kilogram = + 0
               ; meter    = + 0
               ; second   = + 1 }

≠0-mult :
  (m n : ℕ) (hm : NonZero m) (hn : NonZero n) → NonZero (m ℕ.* n)
≠0-mult ℕ.zero    n         () hn
≠0-mult m         0         hm ()
≠0-mult (ℕ.suc m) (ℕ.suc n) hm hn = _

------------------------------------------------
-- UNITS
-- A unit is a dimension together with a coefficient
-- 60 , _ # sec represents a minute (60 seconds)

module Unit where

  infix 1 _,_#_

  data unit : Set where
    _,_#_ : (n : ℕ) (hn : NonZero n) (d : dimension) → unit

  coeff : (u : unit) → ℕ
  coeff (k , _ # _) = k

  coeff≠0 : (u : unit) → NonZero (coeff u)
  coeff≠0 (k , hk # _) = hk

  _*_ : (u v : unit) → unit
  (k , hk # d) * (l , hl # e) =
    ( k ℕ.* l ) , (≠0-mult k l hk hl) # (d Dimension.* e)

  _/_ : (u v : unit)
        ⦃ ≠0 : NonZero (((coeff u) div (coeff v)) ⦃ coeff≠0 v ⦄) ⦄ →
        unit
  _/_ (k , hk # d) (l , hl # e) ⦃ ≠0 ⦄ =
    (k div l) ⦃ hl ⦄ , ≠0 # (d Dimension./ e)

open Unit using (unit ; _,_#_ ; coeff ; coeff≠0)

------------------------------------------------
-- VALUES
-- Finally, values are natural numbers repackaged
-- with a unit

module Values where

  data [_] : (d : unit) → Set where
    ⟨_∶_⟩ : (value : ℕ) (d : unit) → [ d ]

  val : ∀ {d} → [ d ] → ℕ
  val ⟨ m ∶ _ ⟩ = m

  infix 3 _+_
  infix 4 _*_ _/_

  _+_ : ∀ {k hk l hl m hm} {d : dimension} (v₁ : [ k , hk # d ])
        (v₂ : [ l , hl # d ]) → [ m , hm # d ]
  _+_ {k} {hk} {l} {hl} {m} {hm} ⟨ v₁ ∶ ._ ⟩ ⟨ v₂ ∶ ._ ⟩ =
      ⟨ ((k ℕ.* v₁ ℕ.+ l ℕ.* v₂) div m) ⦃ hm ⦄ ∶ _ ⟩

  _:+_ : ∀ {k hk l hl} {d : dimension} (v₁ : [ k , hk # d ])
         (v₂ : [ l , hl # d ]) → [ 1 , _ # d ]
  _:+_ = _+_

  _*_ : ∀ {k hk l hl m hm} {d e : dimension}
        (vd : [ k , hk #  d ]) (ve : [ l , hl # e ]) →
        [ m , hm # (d Dimension.* e) ]
  _*_ {k} {hk} {l} {hl} {m} {hm} ⟨ vd ∶ ._ ⟩ ⟨ ve ∶ ._ ⟩ =
      ⟨ ((k ℕ.* vd ℕ.* l ℕ.* ve) div m) ⦃ hm ⦄ ∶ _ ⟩

  _:*_ : ∀ {k hk l hl} {d e : dimension}
         (vd : [ k , hk #  d ]) (ve : [ l , hl # e ]) →
         [ 1 , _ # (d Dimension.* e) ]
  _:*_ = _*_

  _/_ :  ∀ {k hk l hl m hm} {d e : dimension}
        (vd : [ k , hk #  d ]) (ve : [ l , hl # e ])
        {≠0 : NonZero (val ve)} → [ m , hm # (d Dimension./ e) ]
  _/_ {k} {hk} {l} {hl} {m} {hm} ⟨ vd ∶ ._ ⟩ ⟨ ve ∶ ._ ⟩ {≠0} =
      ⟨ ((k ℕ.* vd) div (l ℕ.* ve ℕ.* m))
          ⦃ ≠0-mult _ _ (≠0-mult _ _ hl ≠0) hm ⦄ ∶ _ ⟩

  ↑ : ∀ {k hk l hl d} → [ k , hk # d ] → [ l , hl # d ]
  ↑ {k} {hk} {l} {hl} ⟨ v ∶ ._ ⟩ = ⟨ ((k ℕ.* v) div l) ⦃ hl ⦄ ∶ _ ⟩

open Values

------------------------------------------------
-- SI PREFIXES
-- They are simply unit-modifying functions.

infix 5 _**_

_**_ : (k : ℕ) {hk : NonZero k} (d : dimension) → unit
_**_ k {hk} d = k , hk # d

centi : (u : unit) {≠0 : NonZero (coeff u div 100)} → unit
centi (k , hk # d) {≠0} = _ , ≠0 # d
deci : (u : unit) {≠0 : NonZero (coeff u div 10)} → unit
deci  (k , hk # d) {≠0} = _ , ≠0 # d
deca hecto kilo : unit → unit
deca  (k , hk # d) = 10   ℕ.* k , ≠0-mult 10   k _ hk # d
hecto (k , hk # d) = 100  ℕ.* k , ≠0-mult 100  k _ hk # d
kilo  (k , hk # d) = 1000 ℕ.* k , ≠0-mult 1000 k _ hk # d

cst : unit
cst =
  let dcst = record { kilogram = + 0
                    ; meter    = + 0
                    ; second   = + 0 }
  in 1 , _ # dcst

infix 3 κ_

κ_ : (n : ℕ) → [ cst ]
κ n = ⟨ n ∶ cst ⟩

------------------------------------------------
-- EXAMPLES

s min hr : unit
s   = 1         ** sec
min = 60        ** sec
hr  = 60 ℕ.* 60 ** sec

m : unit
m = 1 ** met

1s : [ s ]
1s   = ⟨ 1 ∶ s ⟩
1min : [ min ]
1min = ⟨ 1 ∶ min ⟩

1hr 2hr : [ min ]
1hr = ⟨ 60 ∶ min ⟩
2hr = 1hr + 1hr

1min² : [ s Unit.* s ]
1min² = 1min * 1min

60km : [ kilo m ]
60km = ⟨ 60 ∶ kilo m ⟩

60hm : [ hecto m ]
60hm = ⟨ 60 ∶ hecto m ⟩

60hm/min : [ deca m Unit./ s ]
60hm/min = ⟨ 60 ∶ hecto m ⟩ / ⟨ 1 ∶ min ⟩

acc : unit
acc = m Unit./ (s Unit.* s)

spd : unit
spd = m Unit./ s

------------------------------------------------
-- APPLICATION:
-- free fall of a ball with an initial horizontal speed.

record point : Set where
  field
    accx accy : [ acc ]
    vx vy     : [ spd ]
    x y       : [ m   ]
open point public

g : [ acc ]
g = ⟨ 10 ∶ _ ⟩

newton : ∀ (dt : [ s ]) (p : point) → point
newton dt p =
  record { accx = accx p
         ; accy = accy p + g
         ; vx   = vx p   + (accx p :* dt)
         ; vy   = vy p   + (accy p :* dt)
         ; x    = x p    + (vx p   :* dt)
         ; y    = y p    + (vy p   :* dt) }

------------------------------------------------
-- TRACING

-- the initial condition a point is in
base : point
base = record
         { accx = ⟨ 0  ∶ _ ⟩
         ; accy = ⟨ 0  ∶ _ ⟩
         ; vx   = ⟨ 45 ∶ _ ⟩
         ; vy   = ⟨ 0  ∶ _ ⟩
         ; x    = ⟨ 0  ∶ _ ⟩
         ; y    = ⟨ 0  ∶ _ ⟩ }

-- the consecutive steps of its fall
open import Data.Vec     as V using (Vec)

throw : (n : ℕ) (dt : [ s ]) → point → Vec point (ℕ.suc n)
throw  ℕ.zero   dt p = p V.∷ V.[]
throw (ℕ.suc n) dt p = p V.∷ throw n dt (newton dt p)

-- the display function generating the output
open import Data.String     renaming (_++_ to _+s+_)
open import IO
import IO.Primitive
open import Codata.Musical.Colist
open import Data.Nat.Show as Nat
open import Level using (0ℓ)

printPoint : point → IO {0ℓ} ⊤
printPoint p = putStrLn ((Nat.show (val (x p))) +s+ ";" +s+ Nat.show (val (y p)))

main : IO.Primitive.IO ⊤
main = run (Colist.mapM printPoint (Codata.Musical.Colist.fromList trace) >> return _)
  where trace = V.toList $ throw 15 ⟨ 1 ∶ s ⟩ base


open import Agda.Primitive

record Order {ℓ} ℓ' (A : Set ℓ) : Set (ℓ ⊔ lsuc ℓ') where
  field
    _≤_ : A → A → Set ℓ'
open Order {{...}} public

data ℕ : Set where
  Zero : ℕ
  Succ : ℕ → ℕ

data _≤ⁿ_ : ℕ → ℕ → Set where
  Zero : ∀ {n} → Zero ≤ⁿ n
  Succ : ∀ {n₁ n₂} → n₁ ≤ⁿ n₂ → Succ n₁ ≤ⁿ Succ n₂

instance
  Order[ℕ] : Order lzero ℕ
  Order[ℕ] = record { _≤_ = _≤ⁿ_ }

subtract : ∀ (n₁ n₂ : ℕ) → n₂ ≤ n₁ → ℕ
subtract   n₁      .Zero      Zero    = n₁
subtract .(Succ _) .(Succ _) (Succ P) = subtract _ _ P


import      Lvl
open import Structure.Operator.Vector
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.Subspaces.Span
  {ℓᵥ ℓₛ ℓᵥₑ ℓₛₑ}
  {V : Type{ℓᵥ}} ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  {S : Type{ℓₛ}} ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  {_+ᵥ_ : V → V → V}
  {_⋅ₛᵥ_ : S → V → V}
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  ⦃ vectorSpace : VectorSpace(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) ⦄
  where

open VectorSpace(vectorSpace)

open import Logic.Predicate
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.Finite
open import Numeral.Natural
open import Sets.ExtensionalPredicateSet as PredSet using (PredSet ; _∈_ ; [∋]-binaryRelator)
open import Structure.Container.SetLike using (SetElement)
private open module SetLikeFunctionProperties{ℓ} = Structure.Container.SetLike.FunctionProperties{C = PredSet{ℓ}(V)}{E = V}(_∈_)
open import Structure.Function.Multi
open import Structure.Operator
open import Structure.Operator.Vector.LinearCombination        ⦃ vectorSpace = vectorSpace ⦄
open import Structure.Operator.Vector.LinearCombination.Proofs
open import Structure.Operator.Vector.Subspace                 ⦃ vectorSpace = vectorSpace ⦄
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Transitivity

private variable n : ℕ
private variable vf : Vec(n)(V)
private variable sf : Vec(n)(S)

Span : Vec(n)(V) → PredSet(V)
Span(vf) = PredSet.⊶(linearCombination(vf))

Span-subspace : ∀{vf} → Subspace(Span{n}(vf))
∃.witness (_closed-under₂_.proof (Subspace.add-closure (Span-subspace {vf = vf})) ([∃]-intro sf₁) ([∃]-intro sf₂)) = Vec.map₂(_+ₛ_) sf₁ sf₂
∃.proof (_closed-under₂_.proof (Subspace.add-closure (Span-subspace {vf = vf})) {v₁} {v₂} ([∃]-intro sf₁ ⦃ p₁ ⦄) ([∃]-intro sf₂ ⦃ p₂ ⦄)) =
  linearCombination vf (Vec.map₂(_+ₛ_) sf₁ sf₂)            🝖[ _≡_ ]-[ preserving₂(linearCombination vf) (Vec.map₂(_+ₛ_)) (_+ᵥ_) ]
  (linearCombination vf sf₁) +ᵥ (linearCombination vf sf₂) 🝖[ _≡_ ]-[ congruence₂(_+ᵥ_) ⦃ [+ᵥ]-binary-operator ⦄ p₁ p₂ ]
  v₁ +ᵥ v₂                                                 🝖-end
∃.witness (_closed-under₁_.proof (Subspace.mul-closure Span-subspace {s}) ([∃]-intro sf)) = Vec.map(s ⋅ₛ_) sf
∃.proof (_closed-under₁_.proof (Subspace.mul-closure (Span-subspace {vf = vf}) {s}) {v} ([∃]-intro sf ⦃ p ⦄)) =
  linearCombination vf (i ↦ s ⋅ₛ sf(i)) 🝖[ _≡_ ]-[ preserving₁(linearCombination vf) (Vec.map(s ⋅ₛ_)) (s ⋅ₛᵥ_) ]
  s ⋅ₛᵥ (linearCombination vf sf)       🝖[ _≡_ ]-[ congruence₂ᵣ(_⋅ₛᵥ_)(s) p ]
  s ⋅ₛᵥ v                               🝖-end


module Calculator where

open import Human.Humanity hiding (_==_)
open import Human.Nat public hiding (_==_)
open import Human.Char public
open import Human.Equality public

--------- Data ---------
-- Generic proof to proof "Or" operation. Proof that one of the arguments must be true
data Either (A B : Set) : Set where
  fst : A -> Either A B
  snd : B -> Either A B

-- Declaring a set of operations
data Operation : Set where
  add sub mul : Operation

-- It's used to identify which number will be updated, the one on the right or left
data Side : Set where
  right left : Side

-- Can be a number, an operation symbol or execution command
data Event : Set where
  clr : Event -- base case
  num : Side -> Nat -> Event -- a digit
  ope : Operation -> Event -- operator

data State : Set where
  state : Operation → Nat → Nat → State

--------- Auxiliar properties ---------
-- Proof of commutativity of addition. Proof by beala
x+0 : (a : Nat) → (a + 0) == a
x+0 zero    = refl
x+0 (suc a) rewrite x+0 a = refl

-- Agda knows that 0 * a == 0, now we are telling that "a * 0 == 0 * a"
a*0 : (a : Nat) -> (a * 0) == 0
a*0 zero    = refl
a*0 (suc a) rewrite (a*0 a) = refl -- does that 0 * a == 0

-- Proof that 1 is identity element of multiply over nats. Proof by beala
a*1 : (a : Nat) -> (a * 1) == a
a*1 zero    = refl
a*1 (suc a) rewrite a*1 a | a*0 a | x+0 a = refl

-- Tells Agda that 1 * a == a
1*a : (a : Nat) -> (1 * a) == a
1*a zero    = refl
1*a (suc a) rewrite 1*a a = refl

--------- Calculator ---------
-- Initial state
init : State
init = (state add 0 0)

-- Calculates the operation related to a state
result : State -> Nat
result (state add a b) = (a + b)
result (state sub a b) = (a - b)
result (state mul a b) = (a * b)

-- Get the current State, an Event and update to a new State
updateState : State -> Event -> State
-- clear
updateState s               clr          = init
-- "num operation": update the numbers values
updateState (state op m n) (num right x) = (state op m x)
updateState (state op m n) (num left x)  = (state op x n)
-- execute an operation
updateState (state op m n) (ope e) = (state e m n)

--------- Testing Calculator ---------
testUpState0 : State -- add a number on the left
testUpState0 = (updateState init (num left 1))

testUpState1 : State -- add a number on the right
testUpState1 = (updateState testUpState0 (num right 1))

testUpState2 : State -- executes an operation on both numbers
testUpState2 = (updateState testUpState1 (ope add))

-- A type of test as is usually done in other programming languages. Given some input what do I expect as result?
testUpStateResult : (result (updateState testUpState1 (ope add))) == 2
testUpStateResult = refl

testUpState0a : State -- add a number on the left
testUpState0a = (updateState init (num left 3))

testUpState1a : State -- add a number on the right
testUpState1a = (updateState testUpState0a (num right 5))

testUpState2a : State -- executes an operation on both numbers
testUpState2a = (updateState testUpState1a (ope mul))

testUpState0b : State
testUpState0b = (updateState testUpState2a (clr))

--------- Theorems ---------
-- Proofs that the result showing up an operation will always do that operation --
theorem-0 : (s : State) -> (a b : Nat) -> (result (state add a b)) == (a + b)
theorem-0 s a b = refl

theorem-1 : (s : State) -> (a b : Nat) -> (result (state sub a b)) == (a - b)
theorem-1 s a b = refl

theorem-2 : (s : State) -> (a b : Nat) -> (result (state mul a b)) == (a * b)
theorem-2 s a b = refl

-- Given a and b and a proof that one of them is 0, then the result of multiplicating a and b must be 0
theorem-3 : ∀ (a b : Nat) -> Either (a == 0) (b == 0) -> (a * b) == 0
theorem-3 .0 b (fst refl) = refl -- Agda knows that 0 * n == 0 (refl)
theorem-3 a .0 (snd refl) = (a*0 a) -- then we proof that n * 0 is also 0

-- if a == 1: (mul a b) == b
-- if b == 1: (mul a b) == a
-- if a == 1 OR b == 1: Either ((mul a b) == b) ((mul a b) == a)
-- Given a and b and a proof that one of them is 1,
-- then the result of multiplicating a and b must be the number that is not 1
theorem-4 : ∀ (a b : Nat) -> Either (a == 1) (b == 1) -> Either ((a * b) == b) ((a * b) == a)
theorem-4 .1 b (fst refl) = fst (1*a b) -- A proof that 1 * b == b
theorem-4 a .1 (snd refl) = snd (a*1 a) -- A proof that b * 1 == b

-- Proof that update state works as expected
update-theorem : ∀ (x y : Nat) → (s : State) → (result (updateState (updateState (updateState s (num left x)) (ope add)) (num right y))) == (x + y)
update-theorem x y (state op m n) = refl

-- TODO --
-- -- Evaluates several expressions. E.g. (2 + 3) * 5
-- data Expression : Set where
--   num : Nat -> Expression
--   add : Expression -> Expression -> Expression
--   sub : Expression -> Expression -> Expression

----- VIEW? -----
-- main : Program
-- main _ = do
--
--   print "-- Calculator --"
--   -- Receives a number, an operation symbol and a execution command
--
--   let result = exe-operation 2 3 add
--   print (show result)

  -- let result2 = (primNatToChar (exe-operation 2 3 add))
  -- print (primShowChar result2)

  -- for i from 0 to 10 do:
  --   print ("i: " ++ show i)
  --
  -- if (2 == 2)
  --   (then: print "foo")
  --   (else: print "bar")
  --
  -- let num =
  --       init 0.0
  --       for i from 0 to 1000000 do:
  --         λ result → result f+ 1.0

  -- print (primShowFloat num)


open import Data.Boolean
open import Type

module Data.List.Sorting.QuickSort {ℓ} {T : Type{ℓ}} (_≤?_ : T → T → Bool) where

import      Lvl
open import Data.List
open import Data.List.Functions as List using (_++_)
import      Data.List.Functions.Multi as List
open import Data.Tuple
import      Numeral.Finite.Conversions as 𝕟
open import Functional using (_∘_)

{-# TERMINATING #-}
quickSort : List(T) → List(T)
quickSort ∅       = ∅
quickSort (x ⊰ l)
  with (less , great) ← List.separateBy(left 𝕟.bool ∘ (x ≤?_)) l
  = quickSort(less) ++ (x ⊰ quickSort(great))

module Proofs where


module SAcc where

data Size : Set where
  s : Size -> Size

data Acc ( A : Set ) ( Lt : A -> A -> Set) : Size -> A -> Set where
  acc :   (i : Size) ->  ( b : A )
        -> ( ( a : A ) -> Lt a b  ->  Acc A Lt i a )
        -> ( Acc A Lt (s i) b )

data Nat : Set where
  zero : Nat
  succ : Nat -> Nat

data Lt : Nat -> Nat -> Set where
  ltzero : ( x : Nat ) -> Lt zero (succ x)
  ltsucc : ( x : Nat ) -> (y : Nat) -> Lt x y -> Lt (succ x) (succ y)

notLt0 : ( x : Nat ) -> Lt x zero -> (C : Set) -> C
notLt0 x ()

accLt : (i : Size ) -> ( x : Nat ) -> Acc Nat Lt i x
accLt (s i) zero = acc i zero (\a -> \p -> notLt0 a p (Acc Nat Lt i a) )
accLt (s i) (succ x) = acc i (succ x) (\a -> \p -> (accLt i a))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to Fin, and operations making use of these
-- properties (or other properties not available in Data.Fin)
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.Fin.Properties where

open import Category.Applicative using (RawApplicative)
open import Category.Functor using (RawFunctor)
open import Data.Bool.Base using (Bool; true; false; not; _∧_; _∨_)
open import Data.Empty using (⊥-elim)
open import Data.Fin.Base
open import Data.Fin.Patterns
open import Data.Nat.Base as ℕ using (ℕ; zero; suc; s≤s; z≤n; _∸_)
import Data.Nat.Properties as ℕₚ
open import Data.Unit using (tt)
open import Data.Product using (∃; ∃₂; ∄; _×_; _,_; map; proj₁; uncurry; <_,_>)
open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_])
open import Data.Sum.Properties using ([,]-map-commute; [,]-∘-distr)
open import Function.Base using (_∘_; id; _$_)
open import Function.Equivalence using (_⇔_; equivalence)
open import Function.Injection using (_↣_)
open import Relation.Binary as B hiding (Decidable)
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≢_; refl; sym; trans; cong; subst; module ≡-Reasoning)
open import Relation.Nullary.Decidable as Dec using (map′)
open import Relation.Nullary.Reflects
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Nullary
  using (Reflects; ofʸ; ofⁿ; Dec; _because_; does; proof; yes; no; ¬_)
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Nullary.Sum using (_⊎-dec_)
open import Relation.Unary as U
  using (U; Pred; Decidable; _⊆_; Satisfiable; Universal)
open import Relation.Unary.Properties using (U?)

------------------------------------------------------------------------
-- Fin
------------------------------------------------------------------------

¬Fin0 : ¬ Fin 0
¬Fin0 ()

------------------------------------------------------------------------
-- Properties of _≡_
------------------------------------------------------------------------

suc-injective : ∀ {o} {m n : Fin o} → Fin.suc m ≡ suc n → m ≡ n
suc-injective refl = refl

infix 4 _≟_

_≟_ : ∀ {n} → B.Decidable {A = Fin n} _≡_
zero  ≟ zero  = yes refl
zero  ≟ suc y = no λ()
suc x ≟ zero  = no λ()
suc x ≟ suc y = map′ (cong suc) suc-injective (x ≟ y)

------------------------------------------------------------------------
-- Structures

≡-isDecEquivalence : ∀ {n} → IsDecEquivalence (_≡_ {A = Fin n})
≡-isDecEquivalence = record
  { isEquivalence = P.isEquivalence
  ; _≟_           = _≟_
  }

------------------------------------------------------------------------
-- Bundles

≡-preorder : ℕ → Preorder _ _ _
≡-preorder n = P.preorder (Fin n)

≡-setoid : ℕ → Setoid _ _
≡-setoid n = P.setoid (Fin n)

≡-decSetoid : ℕ → DecSetoid _ _
≡-decSetoid n = record
  { isDecEquivalence = ≡-isDecEquivalence {n}
  }

------------------------------------------------------------------------
-- toℕ
------------------------------------------------------------------------

toℕ-injective : ∀ {n} {i j : Fin n} → toℕ i ≡ toℕ j → i ≡ j
toℕ-injective {zero}  {}      {}      _
toℕ-injective {suc n} {zero}  {zero}  eq = refl
toℕ-injective {suc n} {suc i} {suc j} eq =
  cong suc (toℕ-injective (cong ℕ.pred eq))

toℕ-strengthen : ∀ {n} (i : Fin n) → toℕ (strengthen i) ≡ toℕ i
toℕ-strengthen zero    = refl
toℕ-strengthen (suc i) = cong suc (toℕ-strengthen i)

toℕ-raise : ∀ {m} n (i : Fin m) → toℕ (raise n i) ≡ n ℕ.+ toℕ i
toℕ-raise zero    i = refl
toℕ-raise (suc n) i = cong suc (toℕ-raise n i)

toℕ<n : ∀ {n} (i : Fin n) → toℕ i ℕ.< n
toℕ<n zero    = s≤s z≤n
toℕ<n (suc i) = s≤s (toℕ<n i)

toℕ≤pred[n] : ∀ {n} (i : Fin n) → toℕ i ℕ.≤ ℕ.pred n
toℕ≤pred[n] zero                 = z≤n
toℕ≤pred[n] (suc {n = suc n} i)  = s≤s (toℕ≤pred[n] i)

-- A simpler implementation of toℕ≤pred[n],
-- however, with a different reduction behavior.
-- If no one needs the reduction behavior of toℕ≤pred[n],
-- it can be removed in favor of toℕ≤pred[n]′.
toℕ≤pred[n]′ : ∀ {n} (i : Fin n) → toℕ i ℕ.≤ ℕ.pred n
toℕ≤pred[n]′ i = ℕₚ.<⇒≤pred (toℕ<n i)

------------------------------------------------------------------------
-- fromℕ
------------------------------------------------------------------------

toℕ-fromℕ : ∀ n → toℕ (fromℕ n) ≡ n
toℕ-fromℕ zero    = refl
toℕ-fromℕ (suc n) = cong suc (toℕ-fromℕ n)

fromℕ-toℕ : ∀ {n} (i : Fin n) → fromℕ (toℕ i) ≡ strengthen i
fromℕ-toℕ zero    = refl
fromℕ-toℕ (suc i) = cong suc (fromℕ-toℕ i)

------------------------------------------------------------------------
-- fromℕ<
------------------------------------------------------------------------

fromℕ<-toℕ : ∀ {m} (i : Fin m) (i<m : toℕ i ℕ.< m) → fromℕ< i<m ≡ i
fromℕ<-toℕ zero    (s≤s z≤n)       = refl
fromℕ<-toℕ (suc i) (s≤s (s≤s m≤n)) = cong suc (fromℕ<-toℕ i (s≤s m≤n))

toℕ-fromℕ< : ∀ {m n} (m<n : m ℕ.< n) → toℕ (fromℕ< m<n) ≡ m
toℕ-fromℕ< (s≤s z≤n)       = refl
toℕ-fromℕ< (s≤s (s≤s m<n)) = cong suc (toℕ-fromℕ< (s≤s m<n))

-- fromℕ is a special case of fromℕ<.
fromℕ-def : ∀ n → fromℕ n ≡ fromℕ< ℕₚ.≤-refl
fromℕ-def zero    = refl
fromℕ-def (suc n) = cong suc (fromℕ-def n)

------------------------------------------------------------------------
-- fromℕ<″
------------------------------------------------------------------------

fromℕ<≡fromℕ<″ : ∀ {m n} (m<n : m ℕ.< n) (m<″n : m ℕ.<″ n) →
                 fromℕ< m<n ≡ fromℕ<″ m m<″n
fromℕ<≡fromℕ<″ (s≤s z≤n)       (ℕ.less-than-or-equal refl) = refl
fromℕ<≡fromℕ<″ (s≤s (s≤s m<n)) (ℕ.less-than-or-equal refl) =
  cong suc (fromℕ<≡fromℕ<″ (s≤s m<n) (ℕ.less-than-or-equal refl))

toℕ-fromℕ<″ : ∀ {m n} (m<n : m ℕ.<″ n) → toℕ (fromℕ<″ m m<n) ≡ m
toℕ-fromℕ<″ {m} {n} m<n = begin
  toℕ (fromℕ<″ m m<n)  ≡⟨ cong toℕ (sym (fromℕ<≡fromℕ<″ (ℕₚ.≤″⇒≤ m<n) m<n)) ⟩
  toℕ (fromℕ< _)       ≡⟨ toℕ-fromℕ< (ℕₚ.≤″⇒≤ m<n) ⟩
  m ∎
  where open ≡-Reasoning

------------------------------------------------------------------------
-- cast
------------------------------------------------------------------------

toℕ-cast : ∀ {m n} .(eq : m ≡ n) (k : Fin m) → toℕ (cast eq k) ≡ toℕ k
toℕ-cast {n = suc n} eq zero    = refl
toℕ-cast {n = suc n} eq (suc k) = cong suc (toℕ-cast (cong ℕ.pred eq) k)

------------------------------------------------------------------------
-- Properties of _≤_
------------------------------------------------------------------------
-- Relational properties

≤-reflexive : ∀ {n} → _≡_ ⇒ (_≤_ {n})
≤-reflexive refl = ℕₚ.≤-refl

≤-refl : ∀ {n} → Reflexive (_≤_ {n})
≤-refl = ≤-reflexive refl

≤-trans : ∀ {n} → Transitive (_≤_ {n})
≤-trans = ℕₚ.≤-trans

≤-antisym : ∀ {n} → Antisymmetric _≡_ (_≤_ {n})
≤-antisym x≤y y≤x = toℕ-injective (ℕₚ.≤-antisym x≤y y≤x)

≤-total : ∀ {n} → Total (_≤_ {n})
≤-total x y = ℕₚ.≤-total (toℕ x) (toℕ y)

≤-irrelevant : ∀ {n} → Irrelevant (_≤_ {n})
≤-irrelevant = ℕₚ.≤-irrelevant

infix 4 _≤?_ _<?_

_≤?_ : ∀ {n} → B.Decidable (_≤_ {n})
a ≤? b = toℕ a ℕₚ.≤? toℕ b

_<?_ : ∀ {n} → B.Decidable (_<_ {n})
m <? n = suc (toℕ m) ℕₚ.≤? toℕ n

------------------------------------------------------------------------
-- Structures

≤-isPreorder : ∀ {n} → IsPreorder _≡_ (_≤_ {n})
≤-isPreorder = record
  { isEquivalence = P.isEquivalence
  ; reflexive     = ≤-reflexive
  ; trans         = ≤-trans
  }

≤-isPartialOrder : ∀ {n} → IsPartialOrder _≡_ (_≤_ {n})
≤-isPartialOrder = record
  { isPreorder = ≤-isPreorder
  ; antisym    = ≤-antisym
  }

≤-isTotalOrder : ∀ {n} → IsTotalOrder _≡_ (_≤_ {n})
≤-isTotalOrder = record
  { isPartialOrder = ≤-isPartialOrder
  ; total          = ≤-total
  }

≤-isDecTotalOrder : ∀ {n} → IsDecTotalOrder _≡_ (_≤_ {n})
≤-isDecTotalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  ; _≟_          = _≟_
  ; _≤?_         = _≤?_
  }

------------------------------------------------------------------------
-- Bundles

≤-preorder : ℕ → Preorder _ _ _
≤-preorder n = record
  { isPreorder = ≤-isPreorder {n}
  }

≤-poset : ℕ → Poset _ _ _
≤-poset n = record
  { isPartialOrder = ≤-isPartialOrder {n}
  }

≤-totalOrder : ℕ → TotalOrder _ _ _
≤-totalOrder n = record
  { isTotalOrder = ≤-isTotalOrder {n}
  }

≤-decTotalOrder : ℕ → DecTotalOrder _ _ _
≤-decTotalOrder n = record
  { isDecTotalOrder = ≤-isDecTotalOrder {n}
  }

------------------------------------------------------------------------
-- Properties of _<_
------------------------------------------------------------------------
-- Relational properties

<-irrefl : ∀ {n} → Irreflexive _≡_ (_<_ {n})
<-irrefl refl = ℕₚ.<-irrefl refl

<-asym : ∀ {n} → Asymmetric (_<_ {n})
<-asym = ℕₚ.<-asym

<-trans : ∀ {n} → Transitive (_<_ {n})
<-trans = ℕₚ.<-trans

<-cmp : ∀ {n} → Trichotomous _≡_ (_<_ {n})
<-cmp zero    zero    = tri≈ (λ())     refl  (λ())
<-cmp zero    (suc j) = tri< (s≤s z≤n) (λ()) (λ())
<-cmp (suc i) zero    = tri> (λ())     (λ()) (s≤s z≤n)
<-cmp (suc i) (suc j) with <-cmp i j
... | tri< i<j i≢j j≮i = tri< (s≤s i<j)         (i≢j ∘ suc-injective) (j≮i ∘ ℕₚ.≤-pred)
... | tri> i≮j i≢j j<i = tri> (i≮j ∘ ℕₚ.≤-pred) (i≢j ∘ suc-injective) (s≤s j<i)
... | tri≈ i≮j i≡j j≮i = tri≈ (i≮j ∘ ℕₚ.≤-pred) (cong suc i≡j)        (j≮i ∘ ℕₚ.≤-pred)

<-respˡ-≡ : ∀ {n} → (_<_ {n}) Respectsˡ _≡_
<-respˡ-≡ refl x≤y = x≤y

<-respʳ-≡ : ∀ {n} → (_<_ {n}) Respectsʳ _≡_
<-respʳ-≡ refl x≤y = x≤y

<-resp₂-≡ : ∀ {n} → (_<_ {n}) Respects₂ _≡_
<-resp₂-≡ = <-respʳ-≡ , <-respˡ-≡

<-irrelevant : ∀ {n} → Irrelevant (_<_ {n})
<-irrelevant = ℕₚ.<-irrelevant

------------------------------------------------------------------------
-- Structures

<-isStrictPartialOrder : ∀ {n} → IsStrictPartialOrder _≡_ (_<_ {n})
<-isStrictPartialOrder = record
  { isEquivalence = P.isEquivalence
  ; irrefl        = <-irrefl
  ; trans         = <-trans
  ; <-resp-≈      = <-resp₂-≡
  }

<-isStrictTotalOrder : ∀ {n} → IsStrictTotalOrder _≡_ (_<_ {n})
<-isStrictTotalOrder = record
  { isEquivalence = P.isEquivalence
  ; trans         = <-trans
  ; compare       = <-cmp
  }

------------------------------------------------------------------------
-- Bundles

<-strictPartialOrder : ℕ → StrictPartialOrder _ _ _
<-strictPartialOrder n = record
  { isStrictPartialOrder = <-isStrictPartialOrder {n}
  }

<-strictTotalOrder : ℕ → StrictTotalOrder _ _ _
<-strictTotalOrder n = record
  { isStrictTotalOrder = <-isStrictTotalOrder {n}
  }

------------------------------------------------------------------------
-- Other properties

<⇒≢ : ∀ {n} {i j : Fin n} → i < j → i ≢ j
<⇒≢ i<i refl = ℕₚ.n≮n _ i<i

≤∧≢⇒< : ∀ {n} {i j : Fin n} → i ≤ j → i ≢ j → i < j
≤∧≢⇒< {i = zero}  {zero}  _         0≢0     = contradiction refl 0≢0
≤∧≢⇒< {i = zero}  {suc j} _         _       = s≤s z≤n
≤∧≢⇒< {i = suc i} {suc j} (s≤s i≤j) 1+i≢1+j =
  s≤s (≤∧≢⇒< i≤j (1+i≢1+j ∘ (cong suc)))

------------------------------------------------------------------------
-- inject
------------------------------------------------------------------------

toℕ-inject : ∀ {n} {i : Fin n} (j : Fin′ i) →
             toℕ (inject j) ≡ toℕ j
toℕ-inject {i = suc i} zero    = refl
toℕ-inject {i = suc i} (suc j) = cong suc (toℕ-inject j)

------------------------------------------------------------------------
-- inject+
------------------------------------------------------------------------

toℕ-inject+ : ∀ {m} n (i : Fin m) → toℕ i ≡ toℕ (inject+ n i)
toℕ-inject+ n zero    = refl
toℕ-inject+ n (suc i) = cong suc (toℕ-inject+ n i)

------------------------------------------------------------------------
-- inject₁
------------------------------------------------------------------------

inject₁-injective : ∀ {n} {i j : Fin n} → inject₁ i ≡ inject₁ j → i ≡ j
inject₁-injective {i = zero}  {zero}  i≡j = refl
inject₁-injective {i = suc i} {suc j} i≡j =
  cong suc (inject₁-injective (suc-injective i≡j))

toℕ-inject₁ : ∀ {n} (i : Fin n) → toℕ (inject₁ i) ≡ toℕ i
toℕ-inject₁ zero    = refl
toℕ-inject₁ (suc i) = cong suc (toℕ-inject₁ i)

toℕ-inject₁-≢ : ∀ {n}(i : Fin n) → n ≢ toℕ (inject₁ i)
toℕ-inject₁-≢ (suc i) = toℕ-inject₁-≢ i ∘ ℕₚ.suc-injective

------------------------------------------------------------------------
-- inject₁ and lower₁

inject₁-lower₁ : ∀ {n} (i : Fin (suc n)) (n≢i : n ≢ toℕ i) →
                 inject₁ (lower₁ i n≢i) ≡ i
inject₁-lower₁ {zero}  zero     0≢0     = contradiction refl 0≢0
inject₁-lower₁ {suc n} zero     _       = refl
inject₁-lower₁ {suc n} (suc i)  n+1≢i+1 =
  cong suc (inject₁-lower₁ i  (n+1≢i+1 ∘ cong suc))

lower₁-inject₁′ : ∀ {n} (i : Fin n) (n≢i : n ≢ toℕ (inject₁ i)) →
                  lower₁ (inject₁ i) n≢i ≡ i
lower₁-inject₁′ zero    _       = refl
lower₁-inject₁′ (suc i) n+1≢i+1 =
  cong suc (lower₁-inject₁′ i (n+1≢i+1 ∘ cong suc))

lower₁-inject₁ : ∀ {n} (i : Fin n) →
                 lower₁ (inject₁ i) (toℕ-inject₁-≢ i) ≡ i
lower₁-inject₁ i = lower₁-inject₁′ i (toℕ-inject₁-≢ i)

lower₁-irrelevant : ∀ {n} (i : Fin (suc n)) n≢i₁ n≢i₂ →
             lower₁ {n} i n≢i₁ ≡ lower₁ {n} i n≢i₂
lower₁-irrelevant {zero}  zero     0≢0 _ = contradiction refl 0≢0
lower₁-irrelevant {suc n} zero     _   _ = refl
lower₁-irrelevant {suc n} (suc i)  _   _ =
  cong suc (lower₁-irrelevant i _ _)

------------------------------------------------------------------------
-- inject≤
------------------------------------------------------------------------

toℕ-inject≤ : ∀ {m n} (i : Fin m) (le : m ℕ.≤ n) →
                toℕ (inject≤ i le) ≡ toℕ i
toℕ-inject≤ {_} {suc n} zero    _  = refl
toℕ-inject≤ {_} {suc n} (suc i) le = cong suc (toℕ-inject≤ i (ℕₚ.≤-pred le))

inject≤-refl : ∀ {n} (i : Fin n) (n≤n : n ℕ.≤ n) → inject≤ i n≤n ≡ i
inject≤-refl {suc n} zero    _   = refl
inject≤-refl {suc n} (suc i) n≤n = cong suc (inject≤-refl i (ℕₚ.≤-pred n≤n))

inject≤-idempotent : ∀ {m n k} (i : Fin m)
                     (m≤n : m ℕ.≤ n) (n≤k : n ℕ.≤ k) (m≤k : m ℕ.≤ k) →
                     inject≤ (inject≤ i m≤n) n≤k ≡ inject≤ i m≤k
inject≤-idempotent {_} {suc n} {suc k} zero    _   _   _ = refl
inject≤-idempotent {_} {suc n} {suc k} (suc i) m≤n n≤k _ =
  cong suc (inject≤-idempotent i (ℕₚ.≤-pred m≤n) (ℕₚ.≤-pred n≤k) _)

------------------------------------------------------------------------
-- splitAt
------------------------------------------------------------------------

-- Fin (m + n) ≃ Fin m ⊎ Fin n

splitAt-inject+ : ∀ m n i → splitAt m (inject+ n i) ≡ inj₁ i
splitAt-inject+ (suc m) n zero = refl
splitAt-inject+ (suc m) n (suc i) rewrite splitAt-inject+ m n i = refl

splitAt-raise : ∀ m n i → splitAt m (raise {n} m i) ≡ inj₂ i
splitAt-raise zero    n i = refl
splitAt-raise (suc m) n i rewrite splitAt-raise m n i = refl

inject+-raise-splitAt : ∀ m n i → [ inject+ n , raise {n} m ] (splitAt m i) ≡ i
inject+-raise-splitAt zero    n i       = refl
inject+-raise-splitAt (suc m) n zero    = refl
inject+-raise-splitAt (suc m) n (suc i) = begin
  [ inject+ n , raise {n} (suc m) ] (splitAt (suc m) (suc i))  ≡⟨ [,]-map-commute (splitAt m i) ⟩
  [ suc ∘ (inject+ n) , suc ∘ (raise {n} m) ] (splitAt m i)    ≡˘⟨ [,]-∘-distr {f = suc} (splitAt m i) ⟩
  suc ([ inject+ n , raise {n} m ] (splitAt m i))              ≡⟨ cong suc (inject+-raise-splitAt m n i) ⟩
  suc i                                                        ∎
  where open ≡-Reasoning

------------------------------------------------------------------------
-- lift
------------------------------------------------------------------------

lift-injective : ∀ {m n} (f : Fin m → Fin n) →
                 (∀ {x y} → f x ≡ f y → x ≡ y) →
                 ∀ k {x y} → lift k f x ≡ lift k f y → x ≡ y
lift-injective f inj zero                    eq = inj eq
lift-injective f inj (suc k) {0F} {0F}       eq = refl
lift-injective f inj (suc k) {suc i} {suc y} eq = cong suc (lift-injective f inj k (suc-injective eq))

------------------------------------------------------------------------
-- _≺_
------------------------------------------------------------------------

≺⇒<′ : _≺_ ⇒ ℕ._<′_
≺⇒<′ (n ≻toℕ i) = ℕₚ.≤⇒≤′ (toℕ<n i)

<′⇒≺ : ℕ._<′_ ⇒ _≺_
<′⇒≺ {n} ℕ.≤′-refl = subst (_≺ suc n) (toℕ-fromℕ n)
                              (suc n ≻toℕ fromℕ n)
<′⇒≺ (ℕ.≤′-step m≤′n) with <′⇒≺ m≤′n
... | n ≻toℕ i = subst (_≺ suc n) (toℕ-inject₁ i) (suc n ≻toℕ _)

------------------------------------------------------------------------
-- pred
------------------------------------------------------------------------

<⇒≤pred : ∀ {n} {i j : Fin n} → j < i → j ≤ pred i
<⇒≤pred {i = suc i} {zero}  j<i       = z≤n
<⇒≤pred {i = suc i} {suc j} (s≤s j<i) =
  subst (_ ℕ.≤_) (sym (toℕ-inject₁ i)) j<i

------------------------------------------------------------------------
-- _ℕ-_
------------------------------------------------------------------------

toℕ‿ℕ- : ∀ n i → toℕ (n ℕ- i) ≡ n ∸ toℕ i
toℕ‿ℕ- n       zero     = toℕ-fromℕ n
toℕ‿ℕ- (suc n) (suc i)  = toℕ‿ℕ- n i

------------------------------------------------------------------------
-- _ℕ-ℕ_
------------------------------------------------------------------------

nℕ-ℕi≤n : ∀ n i → n ℕ-ℕ i ℕ.≤ n
nℕ-ℕi≤n n       zero     = ℕₚ.≤-refl
nℕ-ℕi≤n (suc n) (suc i)  = begin
  n ℕ-ℕ i  ≤⟨ nℕ-ℕi≤n n i ⟩
  n        ≤⟨ ℕₚ.n≤1+n n ⟩
  suc n    ∎
  where open ℕₚ.≤-Reasoning

------------------------------------------------------------------------
-- punchIn
------------------------------------------------------------------------

punchIn-injective : ∀ {m} i (j k : Fin m) →
                    punchIn i j ≡ punchIn i k → j ≡ k
punchIn-injective zero    _       _       refl      = refl
punchIn-injective (suc i) zero    zero    _         = refl
punchIn-injective (suc i) (suc j) (suc k) ↑j+1≡↑k+1 =
  cong suc (punchIn-injective i j k (suc-injective ↑j+1≡↑k+1))

punchInᵢ≢i : ∀ {m} i (j : Fin m) → punchIn i j ≢ i
punchInᵢ≢i (suc i) (suc j) = punchInᵢ≢i i j ∘ suc-injective

------------------------------------------------------------------------
-- punchOut
------------------------------------------------------------------------

-- A version of 'cong' for 'punchOut' in which the inequality argument can be
-- changed out arbitrarily (reflecting the proof-irrelevance of that argument).

punchOut-cong : ∀ {n} (i : Fin (suc n)) {j k} {i≢j : i ≢ j} {i≢k : i ≢ k} → j ≡ k → punchOut i≢j ≡ punchOut i≢k
punchOut-cong zero {zero} {i≢j = 0≢0} = contradiction refl 0≢0
punchOut-cong zero {suc j} {zero} {i≢k = 0≢0} = contradiction refl 0≢0
punchOut-cong zero {suc j} {suc k} = suc-injective
punchOut-cong {suc n} (suc i) {zero} {zero} _ = refl
punchOut-cong {suc n} (suc i) {suc j} {suc k} = cong suc ∘ punchOut-cong i ∘ suc-injective

-- An alternative to 'punchOut-cong' in the which the new inequality argument is
-- specific. Useful for enabling the omission of that argument during equational
-- reasoning.

punchOut-cong′ : ∀ {n} (i : Fin (suc n)) {j k} {p : i ≢ j} (q : j ≡ k) → punchOut p ≡ punchOut (p ∘ sym ∘ trans q ∘ sym)
punchOut-cong′ i q = punchOut-cong i q

punchOut-injective : ∀ {m} {i j k : Fin (suc m)}
                     (i≢j : i ≢ j) (i≢k : i ≢ k) →
                     punchOut i≢j ≡ punchOut i≢k → j ≡ k
punchOut-injective {_}     {zero}   {zero}  {_}     0≢0 _   _     = contradiction refl 0≢0
punchOut-injective {_}     {zero}   {_}     {zero}  _   0≢0 _     = contradiction refl 0≢0
punchOut-injective {_}     {zero}   {suc j} {suc k} _   _   pⱼ≡pₖ = cong suc pⱼ≡pₖ
punchOut-injective {suc n} {suc i}  {zero}  {zero}  _   _    _    = refl
punchOut-injective {suc n} {suc i}  {suc j} {suc k} i≢j i≢k pⱼ≡pₖ =
  cong suc (punchOut-injective (i≢j ∘ cong suc) (i≢k ∘ cong suc) (suc-injective pⱼ≡pₖ))

punchIn-punchOut : ∀ {m} {i j : Fin (suc m)} (i≢j : i ≢ j) →
                   punchIn i (punchOut i≢j) ≡ j
punchIn-punchOut {_}     {zero}   {zero}  0≢0 = contradiction refl 0≢0
punchIn-punchOut {_}     {zero}   {suc j} _   = refl
punchIn-punchOut {suc m} {suc i}  {zero}  i≢j = refl
punchIn-punchOut {suc m} {suc i}  {suc j} i≢j =
  cong suc (punchIn-punchOut (i≢j ∘ cong suc))

punchOut-punchIn : ∀ {n} i {j : Fin n} → punchOut {i = i} {j = punchIn i j} (punchInᵢ≢i i j ∘ sym) ≡ j
punchOut-punchIn zero {j} = refl
punchOut-punchIn (suc i) {zero} = refl
punchOut-punchIn (suc i) {suc j} = cong suc (begin
  punchOut (punchInᵢ≢i i j ∘ suc-injective ∘ sym ∘ cong suc)  ≡⟨ punchOut-cong i refl ⟩
  punchOut (punchInᵢ≢i i j ∘ sym)                             ≡⟨ punchOut-punchIn i ⟩
  j                                                           ∎)
  where open ≡-Reasoning

------------------------------------------------------------------------
-- Quantification
------------------------------------------------------------------------

module _ {n p} {P : Pred (Fin (suc n)) p} where

  ∀-cons : P zero → Π[ P ∘ suc ] → Π[ P ]
  ∀-cons z s zero    = z
  ∀-cons z s (suc i) = s i

  ∀-cons-⇔ : (P zero × Π[ P ∘ suc ]) ⇔ Π[ P ]
  ∀-cons-⇔ = equivalence (uncurry ∀-cons) < _$ zero , _∘ suc >

  ∃-here : P zero → ∃⟨ P ⟩
  ∃-here = zero ,_

  ∃-there : ∃⟨ P ∘ suc ⟩ → ∃⟨ P ⟩
  ∃-there = map suc id

  ∃-toSum : ∃⟨ P ⟩ → P zero ⊎ ∃⟨ P ∘ suc ⟩
  ∃-toSum ( zero , P₀ ) = inj₁ P₀
  ∃-toSum (suc f , P₁₊) = inj₂ (f , P₁₊)

  ⊎⇔∃ : (P zero ⊎ ∃⟨ P ∘ suc ⟩) ⇔ ∃⟨ P ⟩
  ⊎⇔∃ = equivalence [ ∃-here , ∃-there ] ∃-toSum

decFinSubset : ∀ {n p q} {P : Pred (Fin n) p} {Q : Pred (Fin n) q} →
               Decidable Q → (∀ {f} → Q f → Dec (P f)) → Dec (Q ⊆ P)
decFinSubset {zero} Q? P? = yes λ {}
decFinSubset {suc n} {P = P} {Q} Q? P?
  with Q? zero | ∀-cons {P = λ x → Q x → P x}
... | false because [¬Q0] | cons =
  map′ (λ f {x} → cons (⊥-elim ∘ invert [¬Q0]) (λ x → f {x}) x)
       (λ f {x} → f {suc x})
       (decFinSubset (Q? ∘ suc) P?)
... | true  because  [Q0] | cons =
  map′ (uncurry λ P0 rec {x} → cons (λ _ → P0) (λ x → rec {x}) x)
       < _$ invert [Q0] , (λ f {x} → f {suc x}) >
       (P? (invert [Q0]) ×-dec decFinSubset (Q? ∘ suc) P?)

any? : ∀ {n p} {P : Fin n → Set p} → Decidable P → Dec (∃ P)
any? {zero}  {P = _} P? = no λ { (() , _) }
any? {suc n} {P = P} P? = Dec.map ⊎⇔∃ (P? zero ⊎-dec any? (P? ∘ suc))

all? : ∀ {n p} {P : Pred (Fin n) p} →
       Decidable P → Dec (∀ f → P f)
all? P? = map′ (λ ∀p f → ∀p tt) (λ ∀p {x} _ → ∀p x)
               (decFinSubset U? (λ {f} _ → P? f))

private
  -- A nice computational property of `all?`:
  -- The boolean component of the result is exactly the
  -- obvious fold of boolean tests (`foldr _∧_ true`).
  note : ∀ {p} {P : Pred (Fin 3) p} (P? : Decidable P) →
         ∃ λ z → does (all? P?) ≡ z
  note P? = does (P? 0F) ∧ does (P? 1F) ∧ does (P? 2F) ∧ true
          , refl

-- If a decidable predicate P over a finite set is sometimes false,
-- then we can find the smallest value for which this is the case.

¬∀⟶∃¬-smallest : ∀ n {p} (P : Pred (Fin n) p) → Decidable P →
                 ¬ (∀ i → P i) → ∃ λ i → ¬ P i × ((j : Fin′ i) → P (inject j))
¬∀⟶∃¬-smallest zero    P P? ¬∀P = contradiction (λ()) ¬∀P
¬∀⟶∃¬-smallest (suc n) P P? ¬∀P with P? zero
... | false because [¬P₀] = (zero , invert [¬P₀] , λ ())
... |  true because  [P₀] = map suc (map id (∀-cons (invert [P₀])))
  (¬∀⟶∃¬-smallest n (P ∘ suc) (P? ∘ suc) (¬∀P ∘ (∀-cons (invert [P₀]))))

-- When P is a decidable predicate over a finite set the following
-- lemma can be proved.

¬∀⟶∃¬ : ∀ n {p} (P : Pred (Fin n) p) → Decidable P →
          ¬ (∀ i → P i) → (∃ λ i → ¬ P i)
¬∀⟶∃¬ n P P? ¬P = map id proj₁ (¬∀⟶∃¬-smallest n P P? ¬P)

-- The pigeonhole principle.

pigeonhole : ∀ {m n} → m ℕ.< n → (f : Fin n → Fin m) →
             ∃₂ λ i j → i ≢ j × f i ≡ f j
pigeonhole (s≤s z≤n)       f = contradiction (f zero) λ()
pigeonhole (s≤s (s≤s m≤n)) f with any? (λ k → f zero ≟ f (suc k))
... | yes (j , f₀≡fⱼ) = zero , suc j , (λ()) , f₀≡fⱼ
... | no  f₀≢fₖ with pigeonhole (s≤s m≤n) (λ j → punchOut (f₀≢fₖ ∘ (j ,_ )))
...   | (i , j , i≢j , fᵢ≡fⱼ) =
  suc i , suc j , i≢j ∘ suc-injective ,
  punchOut-injective (f₀≢fₖ ∘ (i ,_)) _ fᵢ≡fⱼ

------------------------------------------------------------------------
-- Categorical
------------------------------------------------------------------------

module _ {f} {F : Set f → Set f} (RA : RawApplicative F) where

  open RawApplicative RA

  sequence : ∀ {n} {P : Pred (Fin n) f} →
             (∀ i → F (P i)) → F (∀ i → P i)
  sequence {zero}  ∀iPi = pure λ()
  sequence {suc n} ∀iPi = ∀-cons <$> ∀iPi zero ⊛ sequence (∀iPi ∘ suc)

module _ {f} {F : Set f → Set f} (RF : RawFunctor F) where

  open RawFunctor RF

  sequence⁻¹ : ∀ {A : Set f} {P : Pred A f} →
               F (∀ i → P i) → (∀ i → F (P i))
  sequence⁻¹ F∀iPi i = (λ f → f i) <$> F∀iPi

------------------------------------------------------------------------
-- If there is an injection from a type to a finite set, then the type
-- has decidable equality.

module _ {a} {A : Set a} where

  eq? : ∀ {n} → A ↣ Fin n → B.Decidable {A = A} _≡_
  eq? inj = Dec.via-injection inj _≟_

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

cmp              = <-cmp
{-# WARNING_ON_USAGE cmp
"Warning: cmp was deprecated in v0.15.
Please use <-cmp instead."
#-}
strictTotalOrder = <-strictTotalOrder
{-# WARNING_ON_USAGE strictTotalOrder
"Warning: strictTotalOrder was deprecated in v0.15.
Please use <-strictTotalOrder instead."
#-}

-- Version 0.16

to-from = toℕ-fromℕ
{-# WARNING_ON_USAGE to-from
"Warning: to-from was deprecated in v0.16.
Please use toℕ-fromℕ instead."
#-}
from-to          = fromℕ-toℕ
{-# WARNING_ON_USAGE from-to
"Warning: from-to was deprecated in v0.16.
Please use fromℕ-toℕ instead."
#-}
bounded = toℕ<n
{-# WARNING_ON_USAGE bounded
"Warning: bounded was deprecated in v0.16.
Please use toℕ<n instead."
#-}
prop-toℕ-≤ = toℕ≤pred[n]
{-# WARNING_ON_USAGE prop-toℕ-≤
"Warning: prop-toℕ-≤ was deprecated in v0.16.
Please use toℕ≤pred[n] instead."
#-}
prop-toℕ-≤′ = toℕ≤pred[n]′
{-# WARNING_ON_USAGE prop-toℕ-≤′
"Warning: prop-toℕ-≤′ was deprecated in v0.16.
Please use toℕ≤pred[n]′ instead."
#-}
inject-lemma = toℕ-inject
{-# WARNING_ON_USAGE inject-lemma
"Warning: inject-lemma was deprecated in v0.16.
Please use toℕ-inject instead."
#-}
inject+-lemma = toℕ-inject+
{-# WARNING_ON_USAGE inject+-lemma
"Warning: inject+-lemma was deprecated in v0.16.
Please use toℕ-inject+ instead."
#-}
inject₁-lemma = toℕ-inject₁
{-# WARNING_ON_USAGE inject₁-lemma
"Warning: inject₁-lemma was deprecated in v0.16.
Please use toℕ-inject₁ instead."
#-}
inject≤-lemma = toℕ-inject≤
{-# WARNING_ON_USAGE inject≤-lemma
"Warning: inject≤-lemma was deprecated in v0.16.
Please use toℕ-inject≤ instead."
#-}

-- Version 0.17

≤+≢⇒< = ≤∧≢⇒<
{-# WARNING_ON_USAGE ≤+≢⇒<
"Warning: ≤+≢⇒< was deprecated in v0.17.
Please use ≤∧≢⇒< instead."
#-}

-- Version 1.0

≤-irrelevance = ≤-irrelevant
{-# WARNING_ON_USAGE ≤-irrelevance
"Warning: ≤-irrelevance was deprecated in v1.0.
Please use ≤-irrelevant instead."
#-}
<-irrelevance = <-irrelevant
{-# WARNING_ON_USAGE <-irrelevance
"Warning: <-irrelevance was deprecated in v1.0.
Please use <-irrelevant instead."
#-}

-- Version 1.1

infixl 6 _+′_
_+′_ : ∀ {m n} (i : Fin m) (j : Fin n) → Fin (ℕ.pred m ℕ.+ n)
i +′ j = inject≤ (i + j) (ℕₚ.+-monoˡ-≤ _ (toℕ≤pred[n] i))
{-# WARNING_ON_USAGE _+′_
"Warning: _+′_ was deprecated in v1.1.
Please use `raise` or `inject+` from `Data.Fin` instead."
#-}

-- Version 1.2

fromℕ≤-toℕ = fromℕ<-toℕ
{-# WARNING_ON_USAGE fromℕ≤-toℕ
"Warning: fromℕ≤-toℕ was deprecated in v1.2.
Please use fromℕ<-toℕ instead."
#-}
toℕ-fromℕ≤ = toℕ-fromℕ<
{-# WARNING_ON_USAGE toℕ-fromℕ≤
"Warning: toℕ-fromℕ≤ was deprecated in v1.2.
Please use toℕ-fromℕ< instead."
#-}
fromℕ≤≡fromℕ≤″ = fromℕ<≡fromℕ<″
{-# WARNING_ON_USAGE fromℕ≤≡fromℕ≤″
"Warning: fromℕ≤≡fromℕ≤″ was deprecated in v1.2.
Please use fromℕ<≡fromℕ<″ instead."
#-}
toℕ-fromℕ≤″ = toℕ-fromℕ<″
{-# WARNING_ON_USAGE toℕ-fromℕ≤″
"Warning: toℕ-fromℕ≤″ was deprecated in v1.2.
Please use toℕ-fromℕ<″ instead."
#-}
isDecEquivalence = ≡-isDecEquivalence
{-# WARNING_ON_USAGE isDecEquivalence
"Warning: isDecEquivalence was deprecated in v1.2.
Please use ≡-isDecEquivalence instead."
#-}
preorder = ≡-preorder
{-# WARNING_ON_USAGE preorder
"Warning: preorder was deprecated in v1.2.
Please use ≡-preorder instead."
#-}
setoid = ≡-setoid
{-# WARNING_ON_USAGE setoid
"Warning: setoid was deprecated in v1.2.
Please use ≡-setoid instead."
#-}
decSetoid = ≡-decSetoid
{-# WARNING_ON_USAGE decSetoid
"Warning: decSetoid was deprecated in v1.2.
Please use ≡-decSetoid instead."
#-}


module plfa-code.Decidable where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product using (_×_) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using ()
  renaming (contradiction to ¬¬-intro)
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)
open import plfa-code.Relations using (_<_; z<s; s<s)
open import plfa-code.Isomorphism using (_⇔_)

data Bool : Set where
  true  : Bool
  false : Bool

open Data.Nat using (_≤_; z≤n; s≤s)

infix 4 _≤ᵇ_

_≤ᵇ_ : ℕ → ℕ → Bool
zero ≤ᵇ n       =  true
suc m ≤ᵇ zero   =  false
suc m ≤ᵇ suc n  =  m ≤ᵇ n

_ : (2 ≤ᵇ 4) ≡ true
_ =
  begin
    2 ≤ᵇ 4
  ≡⟨⟩
    1 ≤ᵇ 3
  ≡⟨⟩
    0 ≤ᵇ 2
  ≡⟨⟩
    true
  ∎

_ : (4 ≤ᵇ 2) ≡ false
_ =
  begin
    4 ≤ᵇ 2
  ≡⟨⟩
    3 ≤ᵇ 1
  ≡⟨⟩
    2 ≤ᵇ 0
  ≡⟨⟩
    false
  ∎

T : Bool → Set
T true   =  ⊤
T false  =  ⊥

T→≡ : ∀ (b : Bool) → T b → b ≡ true
T→≡ true tt = refl
T→≡ false ()

≡→T : ∀ {b : Bool} → b ≡ true → T b
≡→T refl  =  tt

≤ᵇ→≤ : ∀ (m n : ℕ) → T (m ≤ᵇ n) → m ≤ n
≤ᵇ→≤ zero    n       tt  =  z≤n
≤ᵇ→≤ (suc m) zero    ()
≤ᵇ→≤ (suc m) (suc n) t   =  s≤s (≤ᵇ→≤ m n t)

≤→≤ᵇ : ∀ {m n : ℕ} → m ≤ n → T (m ≤ᵇ n)
≤→≤ᵇ z≤n        =  tt
≤→≤ᵇ (s≤s m≤n)  =  ≤→≤ᵇ m≤n

data Dec (A : Set) : Set where
  yes :   A → Dec A
  no  : ¬ A → Dec A

¬s≤z : ∀ {m : ℕ} → ¬ (suc m ≤ zero)
¬s≤z ()

¬s≤s : ∀ {m n : ℕ} → ¬ (m ≤ n) → ¬ (suc m ≤ suc n)
¬s≤s ¬m≤n (s≤s m≤n) = ¬m≤n m≤n

_≤?_ : ∀ (m n : ℕ) → Dec (m ≤ n)
zero ≤? n = yes z≤n
suc m ≤? zero = no ¬s≤z
suc m ≤? suc n with m ≤? n
...               | yes m≤n  =  yes (s≤s m≤n)
...               | no ¬m≤n  =  no (¬s≤s ¬m≤n)

---------- practice ----------
open Eq using (cong)

_<?_ : ∀ (m n : ℕ) → Dec (m < n)
zero <? zero = no (λ ())
zero <? suc n = yes z<s
suc m <? zero = no (λ ())
suc m <? suc n with m <? n
...               | yes m<n  =  yes (s<s m<n)
...               | no ¬m<n  =  no λ{ (s<s m<n) → ¬m<n m<n}

_≡ℕ?_ : ∀ (m n : ℕ) → Dec (m ≡ n)
zero ≡ℕ? zero = yes refl
zero ≡ℕ? suc n = no (λ ())
suc m ≡ℕ? zero = no (λ ())
suc m ≡ℕ? suc n with m ≡ℕ? n
(suc m ≡ℕ? suc n) | yes m≡n = yes (cong suc m≡n)
(suc m ≡ℕ? suc n) | no ¬m≡n = no λ{ refl → ¬m≡n refl}

------------------------------

_≤?′_ : ∀ (m n : ℕ) → Dec (m ≤ n)
m ≤?′ n with m ≤ᵇ n | ≤ᵇ→≤ m n | ≤→≤ᵇ {m} {n}
...        | true   | p        | _            = yes (p tt)
...        | false  | _        | ¬p           = no ¬p

⌊_⌋ : ∀ {A : Set} → Dec A → Bool
⌊ yes _ ⌋  =  true
⌊ no  _ ⌋  =  false

_≤ᵇ′_ : ℕ → ℕ → Bool
m ≤ᵇ′ n  =  ⌊ m ≤? n ⌋

toWitness : ∀ {A : Set} {D : Dec A} → T ⌊ D ⌋ → A
toWitness {A} {yes x} tt = x
toWitness {A} {no ¬x} ()

fromWitness : ∀ {A : Set} {D : Dec A} → A → T ⌊ D ⌋
fromWitness {A} {yes x} _ = tt
fromWitness {A} {no ¬x} x = ¬x x

≤ᵇ′→≤ : ∀ {m n : ℕ} → T (m ≤ᵇ′ n) → m ≤ n
≤ᵇ′→≤  =  toWitness

≤→≤ᵇ′ : ∀ {m n : ℕ} → m ≤ n → T (m ≤ᵇ′ n)
≤→≤ᵇ′  =  fromWitness

infixr 6 _∧_

_∧_ : Bool → Bool → Bool
true  ∧ true  = true
false ∧ _     = false
_     ∧ false = false

infixr 6 _×-dec_

_×-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A × B)
yes x ×-dec yes y = yes ⟨ x , y ⟩
no ¬x ×-dec _     = no λ{ ⟨ x , y ⟩ → ¬x x}
_     ×-dec no ¬y = no λ{ ⟨ x , y ⟩ → ¬y y}

infixr 5 _∨_

_∨_ : Bool → Bool → Bool
true  ∨ _      = true
_     ∨ true   = true
false ∨ false  = false

infixr 5 _⊎-dec_

_⊎-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⊎ B)
yes x ⊎-dec _     = yes (inj₁ x)
_     ⊎-dec yes y = yes (inj₂ y)
no ¬x ⊎-dec no ¬y = no λ{ (inj₁ x) → ¬x x ; (inj₂ y) → ¬y y }

not : Bool → Bool
not true  = false
not false = true

¬? : ∀ {A : Set} → Dec A → Dec (¬ A)
¬? (yes x)  =  no (¬¬-intro x)
¬? (no ¬x)  =  yes ¬x

_⊃_ : Bool → Bool → Bool
_     ⊃ true   =  true
false ⊃ _      =  true
true  ⊃ false  =  false

_→-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A → B)
_     →-dec yes y = yes (λ _ → y)
no ¬x →-dec _     = yes (λ x → ⊥-elim (¬x x))
yes x →-dec no ¬y = no (λ f → ¬y (f x))

---------- practice ----------
∧-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∧ ⌊ y ⌋ ≡ ⌊ x ×-dec y ⌋
∧-× (yes x) (yes y) = refl
∧-× (yes x) (no ¬y) = refl
∧-× (no x)  _       = refl

-- I think there is a typo, so I write ∨-⊎ instead of the origin ∨-×
∨-⊎ : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∨ ⌊ y ⌋ ≡ ⌊ x ⊎-dec y ⌋
∨-⊎ (yes x) _       = refl
∨-⊎ (no ¬x) (yes y) = refl
∨-⊎ (no ¬x) (no ¬y) = refl

not-¬ : ∀ {A : Set} (x : Dec A) → not ⌊ x ⌋ ≡ ⌊ ¬? x ⌋
not-¬ (yes x) = refl
not-¬ (no ¬x) = refl


module Haskell.Prim.Either where

open import Haskell.Prim
open import Haskell.Prim.Bool

--------------------------------------------------
-- Either

data Either (a b : Set) : Set where
  Left  : a → Either a b
  Right : b → Either a b

either : (a → c) → (b → c) → Either a b → c
either f g (Left  x) = f x
either f g (Right y) = g y

testBool : (b : Bool) → Either (IsFalse b) (IsTrue b)
testBool false = Left  itsFalse
testBool true  = Right itsTrue


{-
This second-order signature was created from the following second-order syntax description:

syntax GroupAction | GA

type
  * : 0-ary
  X : 0-ary

term
  unit : * | ε
  add  : *  *  ->  * | _⊕_ l20
  neg  : *  ->  * | ⊖_ r40
  act  : *  X  ->  X | _⊙_ r30

theory
  (εU⊕ᴸ) a |> add (unit, a) = a
  (εU⊕ᴿ) a |> add (a, unit) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊖N⊕ᴸ) a |> add (neg (a), a) = unit
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = unit
  (εU⊙)      x : X |> act (unit,      x) = x
  (⊕A⊙) g h  x : X |> act (add(g, h), x) = act (g, act(h, x))
-}

module GroupAction.Signature where

open import SOAS.Context

-- Type declaration
data GAT : Set where
  * : GAT
  X : GAT

open import SOAS.Syntax.Signature GAT public
open import SOAS.Syntax.Build GAT public

-- Operator symbols
data GAₒ : Set where
  unitₒ addₒ negₒ actₒ : GAₒ

-- Term signature
GA:Sig : Signature GAₒ
GA:Sig = sig λ
  {  unitₒ  → ⟼₀ *
  ;  addₒ   → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  negₒ   → (⊢₀ *) ⟼₁ *
  ;  actₒ   → (⊢₀ *) , (⊢₀ X) ⟼₂ X
  }

open Signature GA:Sig public


module IPL where

  data _∧_ (P : Set) (Q : Set) : Set where
    ∧-intro : P → Q → (P ∧ Q)

  _⇔_ : (P : Set) → (Q : Set) → Set
  a ⇔ b = (a → b) ∧ (b → a)

  proof₁ : {P Q : Set} → (P ∧ Q) → P
  proof₁ (∧-intro p q) = p

  proof₂ : {P Q : Set} → (P ∧ Q) → Q
  proof₂ (∧-intro p q) = q

  ∧-assoc₁ : { P Q R : Set } → ((P ∧ Q) ∧ R) → (P ∧ (Q ∧ R))
  ∧-assoc₁ (∧-intro (∧-intro p q) r) = ∧-intro p (∧-intro q r)

  ∧-assoc₂ : { P Q R : Set } → (P ∧ (Q ∧ R)) → ((P ∧ Q) ∧ R)
  ∧-assoc₂ (∧-intro p (∧-intro q r)) = ∧-intro (∧-intro p q) r

  ∧-assoc : { P Q R : Set } → ((P ∧ Q) ∧ R) ⇔  (P ∧ (Q ∧ R))
  ∧-assoc = ∧-intro ∧-assoc₁ ∧-assoc₂

  data _∨_ (P Q : Set) : Set where
   ∨-intro₁ : P → P ∨ Q
   ∨-intro₂ : Q → P ∨ Q

  ∨-elim : {A B C : Set} → (A → C) → (B → C) → (A ∨ B) → C
  ∨-elim ac bc (∨-intro₁ a) = ac a
  ∨-elim ac bc (∨-intro₂ b) = bc b

  ∨-comm′ : {P Q : Set} → (P ∨ Q) → (Q ∨ P)
  ∨-comm′ (∨-intro₁ p) = ∨-intro₂ p
  ∨-comm′ (∨-intro₂ q) = ∨-intro₁ q

  ∨-comm : {P Q : Set} → (P ∨ Q) ⇔ (Q ∨ P)
  ∨-comm = ∧-intro ∨-comm′ ∨-comm′

  ∨-assoc : { P Q R : Set } → ((P ∨ Q) ∨ R) → (P ∨ (Q ∨ R))
  ∨-assoc (∨-intro₁ (∨-intro₁ p)) = ∨-intro₁ p
  ∨-assoc (∨-intro₁ (∨-intro₂ q)) = ∨-intro₂ (∨-intro₁ q)
  ∨-assoc (∨-intro₂ r) = ∨-intro₂ (∨-intro₂ r)

  data ⊥ : Set where

  ¬ : Set → Set
  ¬ A = A → ⊥