module z where

-- http://www.cse.chalmers.se/~ulfn/papers/afp08/tutorial.pdf
{-
Dependently Typed Programming in Agda
Ulf Norell1   : Chalmers University, Gothenburg   : ulfn@chalmers.se
James Chapman : Institute of Cybernetics, Tallinn : james@cs.ioc.ee

------------------------------------------------------------------------------
1 Introduction

In Hindley-Milner languages (Haskell, ML) : separation between types and values.

Dependently typed : types can contain (depend on) arbitrary values and
                    appear as arguments and results of ordinary functions

Dependent types enables types to talk about values,
so can encode properties of values as types
whose elements are proofs that the property is true.

So dependently typed programming language can be used as a logic.

To be consistent programs must be total.

------------------------------------------------------------------------------
2 BASICS

based on intuitionistic type theory[4]

--------------------------------------------------
2.1 DATATYPES AND PATTERN MATCHING
-}

data Bool : Set where
  true  : Bool
  false : Bool

{-
type of Bool is
- Set, the type of small types
- There is hierarchy of increasingly large types
- type of Set is Set1, whose type is Set2, ...
-}

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

data Nat : Set where
 zero :       Nat
 suc  : Nat → Nat
{-# BUILTIN NATURAL Nat #-}

_+_ : Nat → Nat → Nat
zero  + m =          m
suc n + m = suc (n + m)
infixl 40 _+_

_*_ : Nat → Nat → Nat
zero  * m = zero
suc n * m = m + n * m
infixl 60 _*_

{-
functions must not crash and must terminate

recursive calls have to be made on structurally smaller arguments

mixfix via  _ : args where the underscores are
-}

_or_ : Bool → Bool → Bool
false or x = x
true  or _ = true -- uses wildcard pattern on "don't care" args
infixr 20 _or_

-- polymorphic function over type A
if_then_else_ : {A : Set} → Bool → A → A → A
if  true then x else y = x
if false then x else y = y
infix 5 if_then_else_

-- types parameterize by other types
data List (A : Set) : Set where
  []   :                List A
  _::_ : A → List A → List A
infixr 40 _::_

-- liberal naming policy enables naming above
data _⋆ (α : Set) : Set where
  ε : α ⋆
  _C_ : α → α ⋆ → α ⋆

{-
whitespace important

--------------------------------------------------
2.2 DEPENDENT FUNCTIONS

result type depends on VALUE of an arg
  (x : A) → B for the
type of functions
- given   : arg x of type A
- returns : result of type B
  - where x may appear in B

special case is when x itself is a type, e.g.,
-}

identity : (A : Set) → A → A
identity A x = x

zero’ : Nat
zero’ = identity Nat zero

{-
identity is a dependent function
- given
  - a type argument A and
  - an element of A
- returns
  - the element

This is how polymorphic functions are encoded in Agda.

example : function which takes a dependent function and applies it to an argument:
-}

apply : (A : Set) (B : A → Set) → ((x : A) → B x) → (a : A) → B a
apply A B f a = f a

{-
shorthand for dependent function types:

        (x : A)   (y : B) → C
for     (x : A) → (y : B) → C

        (x y : A)       → B
for     (x : A) (y : A) → B

elements of dependent function types are lambda terms which may carry explicit type info

alternative ways to identity
identity function above are:
-}

identity2 : (A : Set) → A → A
identity2 = \A x → x

identity3 : (A : Set) → A → A
identity3 = \(A : Set) (x : A) → x

identity4 : (A : Set) → A → A
identity4 = \(A : Set) x → x

{-
--------------------------------------------------
2.3 IMPLICIT ARGUMENTS

Previous section showed how dependent functions taking types as
arguments used to model polymorphic types.

But it is not necessary to say at which point it is applied - that can be inferred.

The identity functions above explicitly provide the type argument.

Avoid explicit type arg via implicit arguments using {}
-}

id : {A : Set} → A → A
id x = x

true’ : Bool
true’ = id true

{-
No restrictions on what arguments can be made implicit.
Not guarantees that an implicit argument can be inferred.

E.g., make 2nd arg of identity function implicit as well:
-}

silly : {A : Set} {x : A} → A -- but type checker cannot figure out 2nd arg
silly {_} {x} = x

false’ : Bool
false’ = silly {x = false} -- must provide via named implicit application syntax f {v}
                           -- must use name if not in order
-- type checker fills in term
-- will not search, only looks at typing constraints and performs unification
one : Nat
one = identity _ (suc zero)

-- example of inferring the typing constraints
_◦_ : {A : Set}{B : A → Set}{C : (x : A) → B x → Set}
      (f : {x : A}(y : B x) → C x y)(g : (x : A) → B x)
      (x : A) → C x (g x)
(f ◦ g) x = f (g x)

plus-two = suc ◦ suc

-- other functions

map : {A B : Set} → (A → B) → List A → List B
map f       []  = []
map f (x :: xs) = f x :: map f xs

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

{-
--------------------------------------------------
-- 2.4 DATATYPE FAMILIES

So far, only used dependent types is to represent polymorphism
-}

data Vec (A : Set) : Nat → Set where
  []   :                           Vec A  zero
  _::_ : {n : Nat} → A → Vec A n → Vec A (suc n)

{-
type of Vec A is Nat → Set
- means that Vec A is a family of types indexed by natural numbers
- for each Nat n, Vec A n is a type
- []   constructs an element in Vec A zero
- _::_ constructs an element in Vec A (suc n) for some n

distinction between parameters and indices of a datatype
- parameterised by type A
- indexed over Nat

type of _::_ is a dependent function type
- 1st arg is an implicit Nat n
- returns type that depends on n 'suc n'

same constructor names for Vec as for List
-  constructor names are not required to be distinct between different datatypes
-}

-- safe head
head : {A : Set} {n : Nat} → Vec A (suc n) →     A
head (x :: xs) = x

tail : {A : Set} {n : Nat} → Vec A (suc n) → Vec A n
tail (x :: xs) = xs

{-
rule for when to include a particular case is:
  if it is type correct you have to include it
-}

--------------------------------------------------
-- DOT PATTERNS : indicate value of an arg deduced by type checking, not pattern matching

vmap : {A B : Set} {n : Nat} → (A → B) → Vec A n → Vec B n
vmap f       []  = []
vmap f (x :: xs) = f x :: vmap f xs

{-
map on Vec is exactly the same map on List
only change is the type

behind the scenes, what happens with the length argument when pattern matching

to see, define new versions of Vec and vmap with fewer implicit arguments:
-}

data Vec2 (A : Set) : Nat → Set where
  nil  :                            Vec2 A  zero
  cons : (n : Nat) → A → Vec2 A n → Vec2 A (suc n)

vmap2 : {A B : Set} (n : Nat) → (A → B) → Vec2 A n → Vec2 B n
vmap2 .zero    f  nil          = nil
vmap2 .(suc n) f (cons n x xs) = cons n (f x) (vmap2 n f xs)

{-
pattern matching on list argument reveals its length
- if nil  then zero
- if cons then suc n

to indicate value of an arg deduced by type checking,
rather than observed by pattern matching,
it is prefixed by a dot (.)

could choose to define vmap by first pattern matching on the length rather than on the list
-}

vmap3 : {A B : Set} (n : Nat) → (A → B) → Vec2 A n → Vec2 B n
vmap3  zero   f  nil           = nil
vmap3 (suc n) f (cons .n x xs) = cons n (f x) (vmap3 n f xs)

{-
rule for when arg should be dotted:
- if there is a unique type correct value for the argument it should be dotted

above, the terms under the dots were valid patterns
- in general they can be arbitrary terms
e.g.,
-}

data Image_el_ {A B : Set}(f : A → B) : B → Set where
  im : (x : A) → Image f el f x

{-
only way to construct an element in the image of f
is to pick an argument x and apply f to x

knowing  that a particular y is in the image of f enables computing the inverse of f on y:
-}

inv : {A B : Set} (f : A → B) (y : B) → Image f el y → A
inv f .(f x) (im x) = x

{-
--------------------------------------------------
ABSURD PATTERNS
-}

-- family of numbers smaller than a given natural number
data Fin : Nat → Set where
  fzero : {n : Nat} →         Fin (suc n) -- smaller than suc n for any n
  fsuc  : {n : Nat} → Fin n → Fin (suc n) -- if i smaller than n then fsuc i is smaller than suc n

-- Now way to construct a Fin smaller than zero.
-- When no possible constructor patterns for a given argument
-- then pattern match with absurd pattern ()

magic : {A : Set} → Fin zero → A
magic ()

{-
Using absurd pattern means no need to give a right hand side,
since no way anyting could given as an arg that would match.

Seems the clause not needed, that checker could tell.
But a case can only be omitted if no type correct way of writing it.

'magic a' has a type correct left hand side

absurd pattern can only be used if there are no valid constructor patterns for the arg.
It is not enough that there are no closed inhabitants of the type.
E.g.,
-}

data Empty : Set where
  empty : Fin zero → Empty

{-
Args of type Empty cannot be matched with absurd pattern,
since there is a valid constructor pattern: 'empty x'
So must write:
-}

magic’ : {A : Set} → Empty → A
magic’ (empty ()) -- magic’ () -- not accepted

-- Extract ith element of the list (starting from 0):
-- Turns a list into a function from indices to elements.
_!_ : {n : Nat} {A : Set} → Vec A n → Fin n → A
[]        ! ()
(x :: xs) !  fzero   = x
(x :: xs) ! (fsuc i) = xs ! i

{-
types ensure no danger of indexing outside the list

reflected in use of absurd in empty case : no possible values for the index
-}

-- constructing a list given a function from indices to elements
tabulate : {n : Nat} {A : Set} → (Fin n → A) → Vec A n
tabulate  {zero} f = []
tabulate {suc n} f = f fzero :: tabulate (f ◦ fsuc) -- recursive call implicitly gets 'n'

{-
tabulate is defined by recursion over the length of the result list,
even though it is an implicit argument.

In general, no correspondance between implicit data and computationally irrelevant data.

------------------------------------------------------------------------------
-- 2.5 PROGRAMS AS PROOFS

Type system can represent propositions as types whose elements are proofs of the proposition.
-}

data   False : Set where -- datatype with no constructors
record True  : Set where -- record type with no fields
                         -- has a single element : the empty record

{-
Could have defined True as datatype with a single element.
But using record def lets checker know there is a unique element of True
and will fill in any implicit arguments of type True with this element.

exploited in trivial:
-}

trivial : True
trivial = _

trivial' : True
trivial' = record {}

{-
where right hand is underscore,
instead of explicitly writing 'record {}'

The 'False' and 'True' propositions enable working with decidable propositions.
Can model decidable propositions as booleans and define
-}

-- takes a VALUE of type Bool
-- returns a Set (i.e., a TYPE)
isTrue : Bool → Set
isTrue true  = True
isTrue false = False

isFalse : Bool → Set
isFalse x = isTrue (not x)

{-
isTrue b is the type of proofs that b equals true.

This technique enables defining safe list lookup function in a different way,
working on simply typed lists and numbers.
-}

-- takes   Nat  VALUES
-- returns Bool VALUES
_<_ : Nat → Nat → Bool
_     < zero  = false
zero  < suc n = true
suc m < suc n = m < n

length : {A : Set} → List A → Nat
length        [] = zero
length (x :: xs) = suc (length xs)

--                                             |
--                                             v
lookup : {A : Set} (xs : List A) (n : Nat) → isTrue (n < length xs) → A
lookup       []       n ()
lookup (x :: xs)  zero   p = x
lookup (x :: xs) (suc n) p = lookup xs n p

{-
Rather than there being no index into the empty list,
there is no proof that a number n is smaller than zero.

In this example, using indexed types to capture the precondition,
as done in '_!_' above, is a little bit nicer,
since do not have to pass an explicit proof object
as done in 'lookup' above.

When properties cannot be easily captured by indexed types, this is a useful alternative.

--------------------------------------------------
DEFINE PROPOSITIONS USING DATATYPE FAMILIES
-}

-- family of proofs of “being equal to x”
-- specify the type by giving it two args
-- type can only be constructed when the two args reduce to the same thing
data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x -- only inhabited at index x where the single proof is refl

-- another exampla
-- compare to def of '_<_' above
data _≤_ : Nat → Nat → Set where
  leq-zero :   {n : Nat} →         zero  ≤     n
  leq-suc  : {m n : Nat} → m ≤ n → suc m ≤ suc n

{-
advantage of this approach
- PATTERN MATCH ON PROOF OBJECT
- makes proving properties of _≤_ easier
- e.g.,
-}

leq-trans : {l m n : Nat} → l ≤ m → m ≤ n → l ≤ n
leq-trans  leq-zero            _  = leq-zero
leq-trans (leq-suc p) (leq-suc q) = leq-suc (leq-trans p q)

{-
------------------------------------------------------------------------------
-- 2.6 WITH : PATTERN MATCH ON RESULT OF INTERMEDIATE COMPUTATION

Haskell : done on right hand side using case

when matching expression in dependently typed language, learn
- shape of expression
- things about other expressions
  - e.g., matching 'Vec A n' reveals info about n
- not captured by usual case expression

to pattern match on an expression e in the def of fun f
- abstract f over value of e
- effectively adding another argument to f
- can then be matched on in usual way
-}

min : Nat → Nat → Nat
min x y with x < y
min x y | true  = x
min x y | false = y

{-
Can abstract over multiple expressions at same time, separated by vertical bars.

Can nest with abstractions.

When matching on arg using WITH, no need to match on args again:
- use ...
-}

filter : {A : Set} → (A → Bool) → List A → List A
filter p [] = []
filter p (x :: xs) with p x
... | true  = x :: filter p xs
... | false =      filter p xs

{-
Example of revealing info via matching.

Compare numbers for equality.
Instead of returning boolean,
return proof of equality or
explanation of why they are not equal.
-}

data _≠_ : Nat → Nat → Set where
  z≠s :   {n : Nat} →          zero ≠ suc n -- different if one is zero and other suc
  s≠z :   {n : Nat} →         suc n ≠ zero  -- vice versa
  s≠s : {m n : Nat} → m ≠ n → suc m ≠ suc n -- both suc but their predecessors are different

data Equal? (n m : Nat) : Set where
  eq  : n ≡ m → Equal? n m
  neq : n ≠ m → Equal? n m

-- now function that returns the explanation

equal? : (n m : Nat) → Equal? n m
--                                  Equal? zero zero
--                                      zero ≡ zero
equal?  zero    zero             = eq  refl
equal?  zero   (suc _)           = neq z≠s
equal? (suc _)  zero             = neq s≠z
equal? (suc n) (suc m) with equal? n m -- matching on proof reveals if predecessors are equal
equal? (suc _) (suc _) | eq refl = eq refl
--                                 Equal? (suc n) (suc m)
--                                      suc n ≠ suc m
--                                          n ≠     m
equal? (suc _) (suc _) | neq p   = neq (s≠s p)

{-
using WITH : expression is abstracted from entire context

means that if expression occurs in type of arg to function or in result type,
occurrence is replaced by the with-argument on the left hand side.

e.g., prove 'filter' only removes some elements
-}

-- to make a sublist, each element can either be dropped or kept
infix 20 _⊆_
data _⊆_ {A : Set} : List A → List A → Set where
  stop :                                   [] ⊆      []
  drop : forall {xs y ys} → xs ⊆ ys →      xs ⊆ y :: ys
  keep : forall {x xs ys} → xs ⊆ ys → x :: xs ⊆ x :: ys

{-
When checker can infer type of an arg in fun type, then can use forall:
– forall {x y} a b → A    shorthand for   {x : _} {y : _} (a : _) (b : _) → A
-}

-- proof that filter computes a sublist of its argument:
lem-filter : {A : Set} (p : A → Bool) (xs : List A)
           → filter p xs ⊆ xs
lem-filter p       [] = stop
lem-filter p (x :: xs) with p x
... | true            = keep (lem-filter p xs)
... | false           = drop (lem-filter p xs)

{-
to prove     lem-filter p (x :: xs)

need to prove : (filter p (x :: xs) | p x) ⊆ x :: xs

when abstracting over p x it will be abstracted from goal type, giving
             lem-filter p (x :: xs) with p x
             ... | px = ?

where p x has been replaced by px in the goal type
                (filter p (x :: xs) | px) ⊆ x :: xs

match px reduce call to filter

             lem-filter p (x :: xs) with p x
             ... | true  = ? {- x :: filter p xs ⊆ x :: xs -}
             ... | false = ? {-      filter p xs ⊆ x :: xs -}

Sometimes WITH useful to abstract over expr that will not be matched,
e.g., expect expr to be instantiated by matching on something else
-}

lem-plus-zero : (n : Nat) → n + zero ≡ n
lem-plus-zero zero = refl
lem-plus-zero (suc n) with n + zero | lem-plus-zero n
... | _ | refl = refl -- suc n ≡ suc n

{-
In suc ("step" case) : match on induction hypothesis : n + zero ≡ n
to prove suc n + zero ≡ suc n

but n + zero does not unify with n

so abstract over n + zero, calling it _,
left with the induction hypothesis m ≡ n and goal suc m ≡ suc n
Now match on induction hypothesis, instantiating _ to n

--------------------------------------------------
-- 2.7 Modules TODO

--------------------------------------------------
-- 2.8 Records
-}

record Point : Set where
  field
    x : Nat
    y : Nat

mkPoint : Nat → Nat → Point
mkPoint a b = record { x = a; y = b }

{-
field projections via module of the same name.
- parameterised by element of record type
- contains projection functions for the fields
- i.e.,
   module Point (p : Point) where
     x : Nat
     y : Nat
- can be used as is or instantiated to a particular record
-}

getX : Point → Nat
getX = Point.x

abs2 : Point → Nat
abs2 p = let open Point p in x * x + y * y

-- TODO pattern match on records

-- can add functions to the module of a record

record Monad (M : Set → Set) : Set1 where
  field
    return :   {A : Set} →   A →             M A
    _>>=_  : {A B : Set} → M A → (A → M B) → M B

  mapM : {A B : Set} → (A → M B) → List A → M (List B)
  mapM f [] = return []
  mapM f (x :: xs) = f x >>= \y →
              mapM f xs >>= \ys →
              return (y :: ys)

mapM’ : {M : Set → Set}
      → Monad M
      → {A B : Set}
      → (A → M B)
      → List A
      → M (List B)
mapM’ Mon f xs = Monad.mapM Mon f xs

--------------------------------------------------
-- 2.9 Exercises

-------------------------
-- Exercise 2.1. Matrix transposition
-- inner vectors are rows
Matrix : Set → Nat → Nat → Set
Matrix A n m = Vec (Vec A n) m

-- (a) function to compute vector containing n copies of element x

vec : {n : Nat} {A : Set} → A → Vec A n
vec  {zero} x = []
vec {suc n} x = x :: vec {n} x

vecTest : Vec Nat 3
vecTest = vec zero

-- (b) point-wise application of vector of functions to vector of arguments

infixl 90 _$_
_$_ : {n : Nat} {A B : Set} → Vec (A → B) n → Vec A n → Vec B n
_$_       []        []  = []
_$_ (f :: fs) (x :: xs) = f x :: fs $ xs

$TestInputFs : Vec (Nat → Nat) 2
$TestInputFs = (_+ 1) :: (_* 2) :: []

$TestInputXs : Vec Nat 2
$TestInputXs =     0 ::      2  :: []

$TestOutput  : Vec Nat 2
$TestOutput  =     1 ::      4  :: []

$Test : $TestInputFs $ $TestInputXs ≡ $TestOutput
$Test = refl

-- (c) matrix transposition in terms of 'vec' and _$_

transpose : forall {A n m} → Matrix A n m → Matrix A m n
transpose         []  = vec []
transpose (xs :: xss) = (vmap _::_ xs) $ (transpose xss)

transposeTestInput : Matrix Nat 2 3
transposeTestInput = r1 :: r2 :: r3 :: []
 where
  r1 = 1 :: 2 :: []
  r2 = 3 :: 4 :: []
  r3 = 5 :: 6 :: []

transposeTestOuput : Matrix Nat 3 2
transposeTestOuput = r1 :: r2 :: []
 where
  r1 = 1 ::  3 :: 5 :: []
  r2 = 2  :: 4 :: 6 :: []

transposeTest : transpose transposeTestInput ≡ transposeTestOuput
transposeTest = refl

-------------------------
-- Exercise 2.2. Vector lookup

-- function composition
_∘_  : ∀ {A B C : Set} → (B → C) → (A → B) → (A → C)
(g ∘ f) x = g (f x)

-- prove 'tabulate' and '!' are each other’s inverses

-- (a) relatively easy
lem-!-tab : ∀ {A n}
          → (f : Fin n → A) → (i : Fin n)
          → ((tabulate f) ! i) ≡ f i
lem-!-tab f  fzero   = refl                   -- (tabulate f ! fzero)  ≡ f  fzero
lem-!-tab f (fsuc i) = lem-!-tab (f ∘ fsuc) i -- (tabulate f ! fsuc i) ≡ f (fsuc i)

-- (b) trickier
lem-tab-! : forall {A n}
          → (xs : Vec A n)
          → tabulate (xs !_) ≡ xs
lem-tab-!       [] = refl
lem-tab-! (x :: xs) -- tabulate (_!_ (x :: xs)) ≡ (x :: xs)
  with tabulate (xs !_) | lem-tab-! xs
... | _y     | refl = refl -- (x :: _y) ≡ (x :: xs)
--    ^        ^
-- Vec A n     _y ≡ xs

-------------------------
-- Exercise 2.3. Sublists (see def above)

-- (a) prove reflexivity and transitivity of ⊆

-- need to name implicits since the interesting one does not come first
⊆-refl : {A : Set} {xs : List A}
       → xs ⊆ xs
⊆-refl {xs =       []} = stop
⊆-refl {xs = x :: xss} = keep (⊆-refl { xs = xss })

{-
   []    []    []
   []    []   [z]
   []   [z]   [z]
  [z]   [z]   [z]
  [z]   [z] [z,z]
  [z] [z,z] [z,z]
[z,z] [z,z] [z,z]
-}

⊆-trans : {A : Set} {xs ys zs : List A}
        → xs ⊆ ys
        →      ys ⊆ zs
        → xs ⊆      zs
--       []   []    []
⊆-trans  stop      stop     = stop

--       []   []   [z]
--      [z]  [z] [z,z]
⊆-trans       xy  (drop yz) = drop (⊆-trans xy yz)

--      []   [z]   [z]
--     [z] [z,z] [z,z]
⊆-trans (drop xy) (keep yz) = drop (⊆-trans xy yz)

--     [z]   [z]   [z]
⊆-trans (keep xy) (keep yz) = keep (⊆-trans xy yz)

⊆-trans' : {A : Set} {xs ys zs : List A}
        → xs ⊆ ys
        →      ys ⊆ zs
        → xs ⊆      zs
⊆-trans'  stop        stop     = stop
⊆-trans'  stop       (drop yz) = drop (⊆-trans'  stop     yz)
⊆-trans' (drop xy)   (drop yz) = drop (⊆-trans' (drop xy) yz)
⊆-trans' (drop xy)   (keep yz) = drop (⊆-trans'       xy  yz)
⊆-trans' (keep xy)   (drop yz) = drop (⊆-trans' (keep xy) yz)
⊆-trans' (keep xy)   (keep yz) = keep (⊆-trans'       xy  yz)

-- sublist TYPE of a specific list (compare to existing sublist RELATION above)
infixr 30 _:::_
data SubList {A : Set} : List A → Set where
  []    : SubList []
  _:::_ : forall x {xs} → SubList xs → SubList (x :: xs)
  skip  : forall {x xs} → SubList xs → SubList (x :: xs)

-- (b) extract list corresponding to a sublist
forget : {A : Set} {xs : List A}
       → SubList xs
       → List A
forget       []  = []
forget (x ::: s) = x :: forget s
forget  (skip s) =      forget s

-- (c) prove SubList is a sublist in the sense of ⊆
lem-forget : {A : Set} {xs : List A}
           → (zs : SubList xs)
           → forget zs ⊆ xs
lem-forget        []  = stop
lem-forget (x ::: zs) = keep (lem-forget zs)
lem-forget  (skip zs) = drop (lem-forget zs)

-- (d) alternative def of filter : satisfies sublist property by construction
filter' : {A : Set}
        → (A → Bool) → (xs : List A)
        → SubList xs
filter' p       []  = []
filter' p (x :: xs) with p x
... | true  = x ::: filter' p xs
... | false = skip (filter' p xs)

-- (e) complement of a sublist
complement : {A : Set} {xs : List A}
           → SubList xs
           → SubList xs
complement              []  = []
complement       (x ::: xs) = skip (complement xs)
complement (skip {x}    xs) = x ::: complement xs

module ComplementTest where
  ll : List Nat
  ll = 1 :: 2 :: 3 :: 4 :: []

  p1 : Nat → Bool
  p1 2 = true
  p1 3 = true
  p1 4 = true
  p1 _ = false

  p2 : Nat → Bool
  p2 2 = true
  p2 4 = true
  p2 _ = false

  sl1 : SubList ll
  sl1 = filter' p1 ll

  sl2 : SubList ll
  sl2 = filter' p2 ll

  sl1Test : sl1 ≡ skip (2 ::: 3 ::: 4 ::: [])
  sl1Test = refl

  sl2Test : sl2 ≡ skip (2 ::: skip (4 ::: []))
  sl2Test = refl

  c1 : SubList ll
  c1 = complement sl1

  c2 : SubList ll
  c2 = complement sl2

  cTest1 : c1 ≡ 1 ::: skip (skip (skip []))
  cTest1 = refl

  cTest2 : c2 ≡ 1 ::: skip (3 ::: skip [])
  cTest2 = refl

-- https://medium.com/@angerman/powersets-in-haskell-1df9684db52a
-- (f) compute all sublists of a given list
sublists : {A : Set}
         → (xs : List A)
         → List (SubList xs)
sublists        [] = [] :: []
sublists (x :: xs) = map (x :::_) (sublists xs) ++ (map skip (sublists xs))

-- 2^3 elements - expected output MUST be in same element ORDER as function result
sublistsTest : sublists (1 :: 2 :: 3 :: []) ≡
  (1 ::: 2 ::: 3 ::: [])  ::
  (1 ::: 2 ::: skip  [])  ::
  (1 ::: skip (3 ::: [])) ::
  (1 ::: skip (skip  [])) ::
  skip  (2 ::: 3 ::: [])  ::
  skip  (2 ::: skip  [])  ::
  skip  (skip (3 ::: [])) ::
  skip  (skip (skip  [])) ::
  []
sublistsTest = refl

{-
------------------------------------------------------------------------------
3 Programming Techniques : VIEWS and UNIVERSE constructions

--------------------------------------------------
3.1 VIEWS

matching can reveal info about term being matched AND terms INSIDE the type matched term

VIEW[5]: datatypes whose purpose is to reveal info about its indices

to use a view, define a view function
- computes an element of the view for arbitrary indices
-}

-- view datatype expressing
-- any Nat can be expressed as 2k or 2k + 1 for some k
-- element of Parity n says if n is even or odd and what k is
data Parity : Nat → Set where
  even : (k : Nat) → Parity     (k * 2)
  odd  : (k : Nat) → Parity (1 + k * 2)

parity : (n : Nat) → Parity n
parity  zero = even zero
parity (suc n) with parity n
...  | even k = odd k
...  | odd  k = even (suc k)
{-
parity (suc     .(k * 2)) | even k = odd k
parity (suc .(1 + k * 2)) | odd  k = even (suc k)
-}

half : Nat → Nat
half n with parity n
...  | even k = k
...  | odd  k = k
{-
-- Note that k is bound in the pattern for the view,
-- not in the dotted pattern for the natural number.
half     .(k * 2) | even k = k
half .(1 + k * 2) | odd  k = k
-}

-------------------------
-- FINDING AN ELEMENT IN A LIST

-- given predicate and list
-- returns if P holds for all elements
-- A proof of All P xs is a list of proofs of P x for each element x of xs.
-- P does not have to be a decidable predicate.
infixr 30 _:all:_
data All {A : Set} (P : A → Set) : List A → Set where
  all[]   :                                  All P       []
  _:all:_ : forall {x xs} → P x → All P xs → All P (x :: xs)

-- to turn a decidable predicate into a general predicate, define:
satisfies : {A : Set} → (A → Bool) → A → Set
satisfies p x = isTrue (p x)

-------------------------
-- exercise : use All to prove 2nd part of correctness of filter
-- - all elements of result satisfies the predicate
--    All (satisfies p) (filter p xs)

-- https://www.javaer101.com/en/article/18631037.html
{-
open import Relation.Binary.PropositionalEquality

filter-lem-b : {A : Set} → (p : A → Bool) → (xs : List A) → All (satisfies p) (filter p xs)
filter-lem-b p []        = vacuo
filter-lem-b p (x :: xs) with p x | inspect p x
... | true  | [ eq ] = holds _ _ (subst isTrue (sym eq) _) (filter-lem-b p xs)
... | false | [ eq ] = filter-lem-b p xs
-}

-- https://stackoverflow.com/questions/38572464/agda-type-isnt-simplified-in-with-block
lem-all-filter : {A : Set}
               → (p : A → Bool) → (xs : List A)
               → All (satisfies p) (filter p xs)
lem-all-filter p [] = all[]
--                                           isTrue   (p x)
lem-all-filter p (x :: xs) with p x | λ (y : satisfies p x) → y :all: lem-all-filter p xs
-- onTrue : (y : True) → All (λ x₁ → isTrue (p x₁)) (x :: filter p xs)
... | true  | onTrue = onTrue _
... | false |      _ = lem-all-filter p xs

-------------------------
-- VIEWS ON LISTS

-- given : decidable predicate on elements of list
-- find element in list that satisfies  predicate,
--  or else all elements satifies negation of the predicate

data Find {A : Set} (p : A → Bool) : List A → Set where
  -- does NOT specify which element to use as a witness in the found case.
  -- (If the view was always to return first (or last) matching element,
  -- force elements of xs (or ys) to satisfy the negation of p.)
  found     : (xs : List A) → (y : A) → satisfies p y → (ys : List A)
            → Find p (xs ++ y :: ys)
  not-found : forall {xs} → All (satisfies (not ◦ p)) xs
            → Find p  xs

-- view function computing an element of Find p xs for any p and xs

-- 1st attempt
{-
find1 : {A : Set} (p : A → Bool) (xs : List A) → Find p xs
find1 p [] = not-found all[]
find1 p (x :: xs) with p x
-- Need to return found on first match.
-- ({ }) is isTrue (p x), even though already matched on p x and found out that it was true.
-- Problem : when abstracting over p x did not know that needed to use the found constructor,
--    so there were no p x to abstract over.
-- WITH does not remember connection between the with-term and the pattern.
... | true  = found [] x {! !} xs
... | false = {! !}
-}

{-
A solution : make this connection explicit with a proof object.
Do NOT abstract over the term itself
- instead rather over arbitrary term of same type
  AND a proof that it is equal to the original term
-}

-- type of elements of type A AND proofs they are equal to some given x in A
data Inspect {A : Set} (x : A) : Set where
  it : (y : A) → x ≡ y → Inspect x

-- construct an element of Inspect x by picking x as thing which is equal to x.
inspect : {A : Set} → (x : A) → Inspect x
inspect x = it x refl

-- lemmas
trueIsTrue   : {x : Bool} → x ≡ true  → isTrue  x
falseIsFalse : {x : Bool} → x ≡ false → isFalse x
trueIsTrue   refl = _
falseIsFalse refl = _

{-
now define find by abstracting over inspect (p x) rather than p x
provide either a proof of p x == true or a proof of p x == false
- can be use in args to 'found' and 'not-found
-}

find : {A : Set}
     → (p : A → Bool) → (xs : List A)
     → Find p xs
find p       [] = not-found all[]
find p (x :: xs) with inspect (p x)
-- When p x is true, inspect (p x) matches 'it true prf' where prf : p x == true.
-- Use lemma to turn into proof of isTrue (p x) needed by 3rd arg of 'found'
... | it true  prf = found [] x (trueIsTrue prf) xs
... | it false prf with find p xs
find p (x :: ._) | it false _   | found xs y py ys = found (x :: xs) y py ys
-- p x is false : use lemma
find p (x :: xs) | it false prf | not-found npxs   = not-found (falseIsFalse prf :all: npxs)

-------------------------
-- INDEXING INTO A LIST

{-
Previously showed two ways of safely indexing into a list.
Both cases used type system to guarantee the index didn’t point outside the list.

In situations where there is no control over value of index (i.e., it might be outside)
a solution is to wrap result of lookup in MAYBE, but MAYBE provides no info.
-}

-- type of proofs that an element x is in a list xs.
data _∈_ {A : Set} (x : A) : List A → Set where
  hd : forall   {xs} →          x ∈ x :: xs -- 1st el is a member
  tl : forall {y xs} → x ∈ xs → x ∈ y :: xs -- any el in tail is member

-- Given proof of x ∈ xs, compute index where x occurs.
-- Count number of tls in proof.
index : forall {A} {x : A} {xs} → x ∈ xs → Nat
index  hd    = zero
index (tl p) = suc (index p)

-- view on Nat with respect to list
data Lookup {A : Set} (xs : List A) : Nat → Set where
  inside  : (x : A) → (p : x ∈ xs) → Lookup xs (index p)
  outside : (m : Nat)              → Lookup xs (length xs + m)

{-
When n is valid, get element at that position and guarantee that element is returned.
No way for 'lookup' to cheat.

When n is outside, get out-of-bounds proof showing by how much.
-}

-- now, guaranteed 'lookup' function
_!'_ : {A : Set}
     → (xs : List A) → (n : Nat)
     → Lookup xs n
[] !' n           = outside n
(x :: xs) !' zero = inside x hd
(x :: xs) !' suc n with xs !' n
...                               | inside y p = inside y (tl p)
(x :: xs) !' suc .(length xs + n) | outside n  = outside n
{-
(x :: xs) !' suc .(index p)       | inside y p = inside y (tl p)
(x :: xs) !' suc .(length xs + n) | outside n  = outside n
-}

--------------------------------------------------
-- TYPE CHECKER FOR λ-CALCULUS


{-# OPTIONS --safe --warning=error --without-K #-}

open import Setoids.Setoids
open import Groups.Definition
open import Groups.Subgroups.Definition
open import Groups.Actions.Definition
open import Sets.EquivalenceRelations
open import Groups.Actions.Definition

module Groups.Actions.Stabiliser {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+_ : A → A → A} {G : Group S _+_} (act : GroupAction G T) where

open GroupAction act
open Setoid T

stabiliserPred : (x : B) → (g : A) → Set d
stabiliserPred x g = (action g x) ∼ x

stabiliserWellDefined : (x : B) → {g h : A} → Setoid._∼_ S g h → (stabiliserPred x g) → stabiliserPred x h
stabiliserWellDefined x {g} {h} g=h gx=x = transitive (actionWellDefined1 (Equivalence.symmetric (Setoid.eq S) g=h)) gx=x
  where
    open Equivalence eq

open Setoid T
open Equivalence (Setoid.eq T)

stabiliserSubgroup : (x : B) → Subgroup G (stabiliserPred x)
Subgroup.isSubset (stabiliserSubgroup x) = stabiliserWellDefined x
Subgroup.closedUnderPlus (stabiliserSubgroup x) gx=x hx=x = transitive associativeAction (transitive (actionWellDefined2 hx=x) gx=x)
Subgroup.containsIdentity (stabiliserSubgroup x) = identityAction
Subgroup.closedUnderInverse (stabiliserSubgroup x) {g} gx=x = transitive (transitive (transitive (actionWellDefined2 (symmetric gx=x)) (symmetric associativeAction)) (actionWellDefined1 (invLeft {g}))) identityAction
  where
    open Group G


module plfa.part1.Midterm where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; sym)
-- you can add any import definitions that you need
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _≤_; _>_; z≤n; s≤s; _≤?_)
open import Data.Nat.Properties using (+-assoc; +-suc; *-suc; +-comm; *-distribˡ-+; *-identityʳ)
open import Relation.Nullary using (yes; no)
open import plfa.part1.Induction using (*-distrib-+; *-zero)
-- used for rewrite
simplify : ∀ {A : Set} (x : A) → x ≡ x
simplify x = refl

sum : ℕ → ℕ
sum 0 = 0
sum n@(suc sn) = sum sn + n

-- Problem 1
-- remove the "postulate" and prove this theorem, which is a version of
--   sum n ≡ n * (n + 1) / 2
---postulate
simple : ∀ (n : ℕ) → (sum n) * 2 ≡ (suc n) * n
simple zero = refl
simple (suc n) rewrite *-distrib-+ (sum n) (suc n) 2
                | simple n
                | simplify  n
                | *-suc n n
                | +-comm n (n * n)
                | sym (+-assoc n (n * n) n)
                | +-comm n (n * n) | +-assoc (n * n) n n
                | sym (+-suc (n * n)  (n + n)) | sym (+-assoc n (n * n) (suc (n + n)))
                | +-comm n (n * n)
                | sym (+-suc (n * n) n)
                | +-assoc (n * n) n (suc (n + n))
                | sym (+-suc (n * n) (n + suc (n + n)))
                | sym (+-suc n (suc (n + n)))
                | sym (+-assoc (n * n) n (suc (suc (n + n))))
                | *-suc n 1
                | *-identityʳ n = refl

-- Problem 2
-- remove the postulate and implement this function, which gives an Natural
-- number approximation of square root
postulate
  sqrt : ℕ → ℕ

-- you can run these test cases
-- _ : sqrt 0 ≡ 0
-- _ = refl
-- _ : sqrt 1 ≡ 1
-- _ = refl
-- _ : sqrt 2 ≡ 1
-- _ = refl
-- _ : sqrt 3 ≡ 1
-- _ = refl
-- _ : sqrt 4 ≡ 2
-- _ = refl
-- _ : sqrt 5 ≡ 2
-- _ = refl
-- _ : sqrt 6 ≡ 2
-- _ = refl
-- _ : sqrt 7 ≡ 2
-- _ = refl
-- _ : sqrt 8 ≡ 2
-- _ = refl
-- _ : sqrt 9 ≡ 3
-- _ = refl
-- _ : sqrt 10 ≡ 3
-- _ = refl
-- _ : sqrt 11 ≡ 3
-- _ = refl
-- _ : sqrt 12 ≡ 3
-- _ = refl
-- _ : sqrt 13 ≡ 3
-- _ = refl
-- _ : sqrt 14 ≡ 3
-- _ = refl
-- _ : sqrt 15 ≡ 3
-- _ = refl
-- _ : sqrt 16 ≡ 4
-- _ = refl
-- _ : sqrt 17 ≡ 4
-- _ = refl
-- _ : sqrt 18 ≡ 4
-- _ = refl
-- _ : sqrt 19 ≡ 4
-- _ = refl
-- _ : sqrt 20 ≡ 4
-- _ = refl
-- _ : sqrt 21 ≡ 4
-- _ = refl
-- _ : sqrt 22 ≡ 4
-- _ = refl
-- _ : sqrt 23 ≡ 4
-- _ = refl
-- _ : sqrt 24 ≡ 4
-- _ = refl
-- _ : sqrt 24 ≡ 4
-- _ = refl
-- _ : sqrt 24 ≡ 4
-- _ = refl
-- _ : sqrt 25 ≡ 5
-- _ = refl
-- _ : sqrt 26 ≡ 5
-- _ = refl
-- _ : sqrt 27 ≡ 5
-- _ = refl


module map-is-fold-Tree where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong)
open Eq.≡-Reasoning

open import map-Tree using (Tree; leaf; node; map-Tree)
open import fold-Tree using (fold-Tree)

postulate
  -- 外延性の公理
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

-- 外延性の公理を利用した証明のための補題
lemma : ∀ {A B C D : Set} → (f : A → C) → (g : B → D) → (tree : Tree A B)
  → map-Tree f g tree ≡ fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) tree
lemma f g (leaf a) =
  begin
    map-Tree f g (leaf a)
  ≡⟨⟩
    leaf (f a)
  ≡⟨⟩
    fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) (leaf a)
  ∎
lemma f g (node treeˡ b treeʳ) =
  begin
    map-Tree f g (node treeˡ b treeʳ)
  ≡⟨⟩
    node (map-Tree f g treeˡ) (g b) (map-Tree f g treeʳ)
  ≡⟨ cong (λ treeʳ′ → node (map-Tree f g treeˡ) (g b) treeʳ′) (lemma f g treeʳ) ⟩
    node (map-Tree f g treeˡ)
         (g b)
         (fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) treeʳ)
  ≡⟨ cong (λ treeˡ′ → node treeˡ′
                           (g b)
                           (fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) treeʳ))
          (lemma f g treeˡ) ⟩
    node (fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) treeˡ)
         (g b)
         (fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) treeʳ)
  ≡⟨⟩
    fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ) (node treeˡ b treeʳ)
  ∎

-- Treeのmapが畳み込みで表現できることの証明
map-is-fold-Tree : ∀ {A B C D : Set} → (f : A → C) → (g : B → D)
  → map-Tree f g ≡ fold-Tree (λ a → leaf (f a)) (λ treeˡ b treeʳ → node treeˡ (g b) treeʳ)
map-is-fold-Tree f g = extensionality (lemma f g)


open import Peano using (ℕ; zero; succ; _+_; Rel)

module Semigroup where

  infix 4 _≡_

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

  record Semigroup {A : Set} (_◇_ : A → A → A) : Set where
    field
      associativity : ∀ x y z → (x ◇ y) ◇ z ≡ x ◇ (y ◇ z)

  record ℕ+-isSemigroup : Semigroup _+_ where
    field
      associativity : ∀ x y z → (x + y) + z ≡ x + (y + z)


{- Name: Bowornmet (Ben) Hudson and Theodore (Ted) Kim

    -- COMP360 Final Project: Group Theory in Agda --

In this project, we define some fundamental ideas of group theory and
prove a few basic theorems about the topic using Agda. For example, we
define what a group is, and give several elementary examples of groups.
We utilize the notion of propositional equality in Agda to prove our
theorems using equation chains.

-}

open import Preliminaries

module finalproject where

  -- addition of nats
  plusNat : Nat → Nat → Nat
  plusNat Z m = m
  plusNat (S n) m = S (plusNat n m)

  -- integers
  data Int : Set where
    _-_ : (n : Nat) → (m : Nat) → Int

  -- negation
  -_ : Int → Int
  - (n - m) = m - n

  -- addition of ints
  plusInt : Int → Int → Int
  plusInt (n1 - m1) (n2 - m2) = plusNat n1 n2 - plusNat m1 m2

  -- operation
  Op : Set → Set
  Op el = el → el → el

  -- record of Group
  {- Definition: a Group is a set G with a binary operation, *, with three properties:
     1.) G has an identity element, e ∈ G, such that ∀ x ∈ G, e*x = x = x*e.
     2.) ∀ x ∈ G, ∃ x' ∈ G such that x*x' = e = x'*x, where e is the identity element of G.
     3.) G is associative. That is, ∀ x y z ∈ G, (x*y)*z = x*(y*z).
  -}
  record Group : Set1 where
    field
      el : Set
      _*_ : Op el
      e : el
      inv : el → el
      assoc :  ∀ x y z → ((x * y) * z) == (x * (y * z))
      ident-l : ∀ x → (e * x) == x
      ident-r : ∀ x → (x * e) == x
      inv-l : ∀ x → ((inv x) * x) == e
      inv-r : ∀ x → (x * (inv x)) == e

  -- first example, Bools with "multiplication" operation. Comparable to Z mod 2
  -- with addition

  -- multiplication of bools
  multB : Bool → Bool → Bool
  multB True True = True
  multB True False = False
  multB False True = False
  multB False False = True

  -- associativity of bools
  assocB : ∀ (x y z : Bool) → multB (multB x y) z == multB x (multB y z)
  assocB True True True = Refl
  assocB True True False = Refl
  assocB True False True = Refl
  assocB True False False = Refl
  assocB False True True = Refl
  assocB False True False = Refl
  assocB False False True = Refl
  assocB False False False = Refl

  -- proof of identity
  multTruel : ∀ (x : Bool) → (multB True x == x)
  multTruel True = Refl
  multTruel False = Refl

  multTruer : ∀ (x : Bool) → (multB x True == x)
  multTruer True = Refl
  multTruer False = Refl

  -- inverses of bools
  invB : Bool → Bool
  invB True = True
  invB False = False

  -- proof of inverses with identity
  invBMultl : ∀ (x : Bool) → (multB (invB x) x == True)
  invBMultl True = Refl
  invBMultl False = Refl

  invBMultr : ∀ (x : Bool) → (multB x (invB x) == True)
  invBMultr True = Refl
  invBMultr False = Refl

  -- proof that the Booleans are a group on multiplication
  Bool*-isgroup : Group
  Bool*-isgroup = record {
               el = Bool;
               _*_ = multB;
               e = True;
               inv = invB;
               assoc = assocB;
               ident-l = multTruel;
               ident-r = multTruer;
               inv-l = invBMultl;
               inv-r = invBMultr }

  -- second example of a group, ints with the addition operation

  -- congruence
  congruenceNatInt : ∀ (a b c d : Nat) → a == c → b == d → a - b == c - d
  congruenceNatInt .c .d c d Refl Refl = Refl

  congruenceNat : ∀ (x y : Nat) → x == y → (S x) == (S y)
  congruenceNat .y y Refl = Refl

  congruenceNat' : ∀ (n m : Nat) → n == m → S n == S m
  congruenceNat' .m m Refl = Refl

  -- lemma
  addZNat : ∀ (x : Nat) → plusNat x Z == x
  addZNat Z = Refl
  addZNat (S x) = congruenceNat (plusNat x Z) x (addZNat x)

  -- proof of associativity
  assocNat+ : (x y z : Nat) → plusNat (plusNat x y) z == plusNat x (plusNat y z)
  assocNat+ Z y z = Refl
  assocNat+ (S x) y z = congruenceNat (plusNat (plusNat x y) z) (plusNat x (plusNat y z)) (assocNat+ x y z)

  assocInt+ : ∀ (a b c : Int) → plusInt (plusInt a b) c == plusInt a (plusInt b c)
  assocInt+ (n1 - m1) (n2 - m2) (n3 - m3) = congruenceNatInt (plusNat (plusNat n1 n2) n3)
                                              (plusNat (plusNat m1 m2) m3) (plusNat n1 (plusNat n2 n3))
                                              (plusNat m1 (plusNat m2 m3)) (assocNat+ n1 n2 n3) (assocNat+ m1 m2 m3)

  -- proof of identity
  addIntZl : ∀ (n : Int) → (plusInt (Z - Z) n == n)
  addIntZl (n - m) = Refl

  addIntZr : ∀ (n : Int) → (plusInt n (Z - Z) == n)
  addIntZr (n - m) = congruenceNatInt (plusNat n 0) (plusNat m 0) n m (addZNat n) (addZNat m)

  -- proof of inverses
  -- issue with quotient type: impossible to prove that (S n) - (S n) = 0 - 0 without equality constructor
  -- had problems in including the equality constructor, only thing we could not work out
  invIntl : ∀ (n : Int) → plusInt (- n) n == (Z - Z)
  invIntl (n - m) = {!!}

  invIntr : ∀ (n : Int) → plusInt n (- n) == (Z - Z)
  invIntr (n - m) = {!!}

  -- proof that the integers on addition are a group
  Int+-isgroup : Group
  Int+-isgroup = record {
              el = Int;
              _*_ = plusInt;
              e = Z - Z;
              inv = -_;
              assoc = assocInt+;
              ident-l = addIntZl;
              ident-r = addIntZr;
              inv-l = invIntl;
              inv-r = invIntr }

   {- Definition: an group is called abelian if it is commutative.
      That is, ∀ x y ∈ G, x*y = y*x. Our record of an abelian group
      requires a group and a proof that the group operation
      is commutative.
   -}
  record AbelianGroup (G : Group) : Set where
    open Group G
    field
      comm : ∀ (x y : el) → x * y == y * x

  -- proof of commutativity for multiplication on bools
  commB : ∀ (x y : Bool) → multB x y == multB y x
  commB True True = Refl
  commB True False = Refl
  commB False True = Refl
  commB False False = Refl

  Bool*-isAbelian : AbelianGroup Bool*-isgroup
  Bool*-isAbelian = record {
                 comm = commB }

  -- some theorems
  module Theorems (G : Group) where
    open Group G
    congruenceOP : {a b c : el} → a == b → a * c == b * c
    congruenceOP Refl = Refl

    congruenceOP' : {a b c : el} → b == c → a * b == a * c
    congruenceOP' Refl = Refl

    sym : {a b : el} → a == b → b == a
    sym Refl = Refl

    -- extremely simple theorem
    babytheorem : (a b : el) → ((a * e) * b) == (a * b)
    babytheorem a b = congruenceOP (ident-r a)

    -- theorem 1: Let G be a group, and let a and b ∈ G. Then (a * b)^-1 = b^-1 * a^-1.
    theorem1 : ∀ (a b : el) → inv (a * b) == (inv b * inv a)
    theorem1 a b  = inv (a * b)                                      =⟨ sym (ident-r (inv (a * b))) ⟩
                    (inv (a * b) * e)                               =⟨ sym (congruenceOP' (inv-r a)) ⟩
                    (inv (a * b) * (a * inv a))                     =⟨ congruenceOP' (congruenceOP (sym (ident-r a))) ⟩
                    (inv (a * b) * ((a * e) * inv a))               =⟨ congruenceOP' (congruenceOP (congruenceOP' (sym (inv-r b)))) ⟩
                    (inv (a * b) * ((a * (b * inv b)) * inv a))     =⟨ congruenceOP' (congruenceOP (sym (assoc a b (inv b)))) ⟩
                    (inv (a * b) * (((a * b) * inv b) * inv a))     =⟨ congruenceOP' (assoc (a * b) (inv b) (inv a)) ⟩
                    (inv (a * b) * ((a * b) * (inv b * inv a)))     =⟨ sym (assoc (inv (a * b)) (a * b) (inv b * inv a)) ⟩
                    ((inv (a * b) * (a * b)) * (inv b * inv a))     =⟨ congruenceOP (inv-l (a * b)) ⟩
                    (e * (inv b * inv a))                           =⟨ ident-l (inv b * inv a) ⟩
                    (inv b * inv a)                                 ∎

    -- theorem 2: Let G be a group, and let a, b, and c ∈ G. If a * c = b * c, then a = b.
    theorem2 : ∀ (a b c : el) → (a * c) == (b * c) → a == b
    theorem2 a b c p = a                            =⟨ sym (ident-r a) ⟩
                       a * e                        =⟨ congruenceOP' (sym (inv-r c)) ⟩
                       (a * (c * inv c))            =⟨ sym (assoc a c (inv c)) ⟩
                       (a * c) * inv c              =⟨ congruenceOP p ⟩
                       (b * c) * inv c              =⟨ assoc b c (inv c) ⟩
                       (b * (c * inv c))            =⟨ congruenceOP' (inv-r c) ⟩
                       (b * e)                      =⟨ ident-r b ⟩
                       b                            ∎

    -- theorem 3: Let G be a group, and let g ∈ G. If g * g = g, then g = e.
    theorem3 : ∀ (g : el) → (g * g) == g → g == e
    theorem3 g p = g                       =⟨ sym (ident-r g) ⟩
                   (g * e)                 =⟨ congruenceOP' (sym (inv-r g)) ⟩
                   (g * (g * inv g))       =⟨ sym (assoc g g (inv g)) ⟩
                   (g * g) * inv g         =⟨ congruenceOP p ⟩
                   g * inv g               =⟨ inv-r g ⟩
                   e                       ∎

    -- lemma 1: for all x ∈ G, if x * x = e, x^-1 = x. That is, x is its own inverse.
    lemma1 : ∀ (x : el) → (p : x * x == e) → inv x == x
    lemma1 x p = (inv x)                          =⟨ sym (ident-r (inv x)) ⟩
                 (inv x * e)                      =⟨ congruenceOP' (sym p) ⟩
                 inv x * (x * x)                  =⟨ sym (assoc (inv x) x x) ⟩
                 (inv x * x) * x                  =⟨ congruenceOP (inv-l x) ⟩
                 (e * x)                          =⟨ ident-l x ⟩
                 x                                ∎

    -- theorem 4: let G be a group. If ∀ x ∈ G, x * x = e, then G is abelian.
    theorem4 : (p : ∀ x → (x * x) == e) → AbelianGroup G
    theorem4 p = record {
                comm = λ a b → a * b                            =⟨ congruenceOP (sym (ident-r a)) ⟩
                               (a * e) * b                      =⟨ congruenceOP (congruenceOP' (sym (inv-r a))) ⟩
                               (a * (a * inv a)) * b            =⟨ congruenceOP (sym (assoc a a (inv a))) ⟩
                               ((a * a) * inv a) * b            =⟨ congruenceOP (congruenceOP (p a)) ⟩
                               (e * inv a) * b                  =⟨ congruenceOP (ident-l (inv a)) ⟩
                               inv a * b                        =⟨ congruenceOP' (sym (ident-r b)) ⟩
                               inv a * (b * e)                  =⟨ congruenceOP' (congruenceOP' (sym (inv-r b))) ⟩
                               inv a * (b * (b * inv b))        =⟨ congruenceOP' (sym (assoc b b (inv b))) ⟩
                               inv a * ((b * b) * inv b)        =⟨ congruenceOP' (congruenceOP (p b)) ⟩
                               inv a * (e * inv b)              =⟨ congruenceOP' (ident-l (inv b)) ⟩
                               (inv a * inv b)                  =⟨ sym (theorem1 b a) ⟩
                               (inv (b * a))                    =⟨ lemma1 (b * a) (p (b * a)) ⟩
                               (b * a)                          ∎ }

    -- theorem 5: Let G be a group, and a, b, and c ∈ G. If (a * b) * c = e, then (b * c) * a = e as well.
    theorem5 : ∀ (a b c : el) → ((a * b) * c) == e → ((b * c) * a) == e
    theorem5 a b c p = ((b * c) * a)                         =⟨ sym (ident-l ((b * c) * a)) ⟩
                       e * ((b * c) * a)                     =⟨ congruenceOP (sym (inv-l a)) ⟩
                       (inv a * a) * ((b * c) * a)           =⟨ assoc (inv a) a ((b * c) * a) ⟩
                       inv a * (a * ((b * c) * a))           =⟨ sym (congruenceOP' (assoc a (b * c) a)) ⟩
                       inv a * ((a * (b * c)) * a)           =⟨ congruenceOP' (congruenceOP (sym (assoc a b c))) ⟩
                       inv a * (((a * b) * c) * a)           =⟨ congruenceOP' (congruenceOP p) ⟩
                       inv a * (e * a)                       =⟨ congruenceOP' (ident-l a) ⟩
                       (inv a * a)                           =⟨ inv-l a ⟩
                       e                                     ∎

  {- Definition: a homomorphism is a function f from a group (G , *) to another group (H , ∘)
     such that (∀ a,b ∈ G), f(a*b) = f(a)∘f(b). Our definition of a homomorphism also includes a
     proof that homomorphisms preserve identity elements between groups. That is, f(e_G) = e_H,
     where e_G and e_H are the identity elements in G and H, respectively.
  -}
  -- record of homomorphisms
  record Homomorphism (G : Group) (H : Group) : Set where
    open Group renaming (_*_ to *)
    field
      f : el G → el H
      preserve-id : f (e G) == e H
      preserve-op : ∀ (a b : el G) → (f (* G a b)) == * H (f a) (f b)

  -- third example of a group, Z mod 2 under addition.
  -- Z mod 2
  data Zmod2 : Set where
    Zero : Zmod2
    One : Zmod2

  -- addition mod 2
  plusmod2 : Zmod2 → Zmod2 → Zmod2
  plusmod2 Zero Zero = Zero
  plusmod2 Zero One = One
  plusmod2 One Zero = One
  plusmod2 One One = Zero

  -- identity of Z mod 2
  idenZmod2-l : (x : Zmod2) → plusmod2 Zero x == x
  idenZmod2-l Zero = Refl
  idenZmod2-l One = Refl

  idenZmod2-r : (x : Zmod2) → plusmod2 x Zero == x
  idenZmod2-r Zero = Refl
  idenZmod2-r One = Refl

  -- inverses of Z mod 2 (the inverse of anything in Z mod 2 is itself)
  invZmod2 : Zmod2 → Zmod2
  invZmod2 x = x

  -- left and right inverses of Z mod 2
  invZmod2-lr : (x : Zmod2) → plusmod2 x x == Zero
  invZmod2-lr Zero = Refl
  invZmod2-lr One = Refl

  -- associativity of addition in Z mod 2
  assocZmod2 : (x y z : Zmod2) → plusmod2 (plusmod2 x y) z == plusmod2 x (plusmod2 y z)
  assocZmod2 Zero Zero Zero = Refl
  assocZmod2 Zero Zero One = Refl
  assocZmod2 Zero One Zero = Refl
  assocZmod2 Zero One One = Refl
  assocZmod2 One Zero Zero = Refl
  assocZmod2 One Zero One = Refl
  assocZmod2 One One Zero = Refl
  assocZmod2 One One One = Refl

  -- commutativity of addition in Z mod 2
  commZmod2 : (x y : Zmod2) → plusmod2 x y == plusmod2 y x
  commZmod2 Zero Zero = Refl
  commZmod2 Zero One = Refl
  commZmod2 One Zero = Refl
  commZmod2 One One = Refl

  -- Zmod2 is a group on addition.
  Zmod2+-isgroup : Group
  Zmod2+-isgroup = record {
                el = Zmod2;
                _*_ = plusmod2;
                e = Zero;
                inv = invZmod2;
                assoc = assocZmod2;
                ident-l = idenZmod2-l;
                ident-r = idenZmod2-r;
                inv-l = λ x → invZmod2-lr x;
                inv-r = λ x → invZmod2-lr x }

  -- proof that Z mod 2 on addition is an abelian group.
  Zmod2+-isAbelian : AbelianGroup (Zmod2+-isgroup)
  Zmod2+-isAbelian = record {
                  comm = commZmod2 }

  -- example of a homomorphism: mapBool-to-Zmod2 is a homomorphism from Bools on multiplication to Zmod2 with addition.
  -- map from Bools to the elements of Zmod2.
  mapBool-to-Zmod2 : Bool → Zmod2
  mapBool-to-Zmod2 True = Zero
  mapBool-to-Zmod2 False = One

  -- proof that the map from Bools to Zmod2 preserves composition.
  mapBool-to-Zmod2-preserve-op : (a b : Bool) → mapBool-to-Zmod2 (multB a b) == plusmod2 (mapBool-to-Zmod2 a) (mapBool-to-Zmod2 b)
  mapBool-to-Zmod2-preserve-op True True = Refl
  mapBool-to-Zmod2-preserve-op True False = Refl
  mapBool-to-Zmod2-preserve-op False True = Refl
  mapBool-to-Zmod2-preserve-op False False = Refl

  homomorphism-example : Homomorphism (Bool*-isgroup) (Zmod2+-isgroup)
  homomorphism-example = record {
                      f = mapBool-to-Zmod2;
                      preserve-id = Refl;
                      preserve-op = mapBool-to-Zmod2-preserve-op }

   -- record of isomorphisms.
  {- Definition: a homomorphism between two groups is called an isomorphism
     if it is bijective (both one-to-one and onto). The isomorphism record
     requires a homomorphism along with proofs that it is both one-to-one
     (injective) and onto (surjective).
  -}
  record Isomorphism (G : Group) (H : Group) : Set where
    open Group
    open Homomorphism
    field
      homomorphism : Homomorphism G H
      injective : ∀ (a b : el G) → f homomorphism a == f homomorphism b → a == b
      surjective : ∀ (b : el H) → Σ (λ g → f homomorphism g == b)

  -- example of an isomorphism
  -- proof that this map from Bools to Zmod2 is injective (that is, ∀ a b : Bool, f(a) = f(b) implies a = b).
  mapB-Zmod2-inj : (a b : Bool) → mapBool-to-Zmod2 a == mapBool-to-Zmod2 b → a == b
  mapB-Zmod2-inj True True p = Refl
  mapB-Zmod2-inj True False ()
  mapB-Zmod2-inj False True ()
  mapB-Zmod2-inj False False p = Refl

  -- proof that this map from Bools to Zmod2 is surjective (that is, ∀ b : Zmod2, ∃ a ∈ Bool such that f(a) = b).
  mapB-Zmod2-sur : (n : Zmod2) → Σ (λ bool → mapBool-to-Zmod2 bool == n)
  mapB-Zmod2-sur Zero = True , Refl
  mapB-Zmod2-sur One = False , Refl

  -- the homomorphism between Bools on multiplication to Zmod2 with addition is isomorphic
  isomorphism-example : Isomorphism Bool*-isgroup Zmod2+-isgroup
  isomorphism-example = record {
                     homomorphism = homomorphism-example;
                     injective = mapB-Zmod2-inj;
                     surjective = mapB-Zmod2-sur }


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

module hott.types.nat where

open import hott.core.universe
open import hott.core.equality
open import hott.functions

data ℕ : Type₀ where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

-- Addition.
_+_   : ℕ → ℕ → ℕ
0       + y = y
succ x  + y = succ (x + y)

-- Multiplication
_*_   : ℕ → ℕ → ℕ
zero   * y = zero
succ x * y = y + (x * y)

-- The interated fucntion
iterate : ∀{ℓ} {A : Type ℓ} → (A → A) → ℕ → A → A
iterate _ zero     = id
iterate f (succ n) = f ∘ iterate f n


open import Functional using (id)
import      Structure.Logic.Constructive.NaturalDeduction

module Structure.Logic.Constructive.Functions.Properties {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ constructiveLogicSign : _ ⦄ where
open Structure.Logic.Constructive.NaturalDeduction.ConstructiveLogicSignature {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} (constructiveLogicSign)

open import Structure.Logic.Constructive.Functions(Domain)
open import Syntax.Function

-- States whether the function f is defined on the element x.
-- Whether f(x) yields/returns an element in the domain.
-- In other words: Whether the logic can interpret f(x) as anything meaningful.
Defined : Function → Domain → Formula
Defined f(x) = ∃ₗ(y ↦ f(x) ≡ y)

-- States whether the function f can yield/return the element y.
Value : Function → Domain → Formula
Value f(y) = ∃ₗ(x ↦ f(x) ≡ y)

Injective : Function → Formula
Injective(f) = ∀ₗ(x ↦ ∀ₗ(y ↦ (f(x) ≡ f(y)) ⟶ (x ≡ y)))

Surjective : Function → Formula
Surjective(f) = ∀ₗ(y ↦ ∃ₗ(x ↦ f(x) ≡ y))

Bijective : Function → Formula
Bijective(f) =
  Injective(f)
  ∧ Surjective(f)

Preserving₁ : Function → Function → Function → Formula
Preserving₁(f)(g₁)(g₂) = ∀ₗ(x ↦ f(g₁(x)) ≡ g₂(f(x)))

Preserving₂ : Function → BinaryOperator → BinaryOperator → Formula
Preserving₂(f)(_▫₁_)(_▫₂_) = ∀ₗ(x ↦ ∀ₗ(y ↦ f(x ▫₁ y) ≡ (f(x) ▫₂ f(y))))

Fixpoint : Function → Domain → Formula
Fixpoint f(x) = (f(x) ≡ x)


module Rev {A : Set} where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong₂; _≢_)
open Eq.≡-Reasoning
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List
  using (List; []; _∷_; _++_; map; foldr; replicate; length; _∷ʳ_)
  -- renaming (reverse to rev)
open import Data.List.Properties
  using (++-assoc; ++-identityʳ)
  -- renaming (unfold-reverse to revʳ;
  --           reverse-++-commute to rev-++;
  --           reverse-involutive to rev-inv)
open import Data.List.All using (All; []; _∷_)
open import Data.List.All.Properties
  renaming (++⁺ to _++All_)

pattern [_]       x        =  x ∷ []
pattern [_,_]     x y      =  x ∷ y ∷ []
pattern [_,_,_]   x y z    =  x ∷ y ∷ z ∷ []
pattern [_,_,_,_] x y z w  =  x ∷ y ∷ z ∷ w ∷ []

rev : List A → List A
rev [] =  []
rev (x ∷ xs) =  rev xs ++ [ x ]

rev-++ : ∀ xs ys → rev (xs ++ ys) ≡ rev ys ++ rev xs
rev-++ [] ys =
  begin
    rev ([] ++ ys)
  ≡⟨ sym (++-identityʳ (rev ys)) ⟩
    rev ys ++ rev []
  ∎
rev-++ (x ∷ xs) ys =
  begin
    rev (x ∷ xs ++ ys)
  ≡⟨⟩
    rev (xs ++ ys) ++ [ x ]
  ≡⟨ cong (_++ [ x ]) (rev-++ xs ys) ⟩
    (rev ys ++ rev xs) ++ [ x ]
  ≡⟨ ++-assoc (rev ys) (rev xs) [ x ] ⟩
    rev ys ++ (rev xs ++ [ x ])
  ≡⟨⟩
    rev ys ++ (rev (x ∷ xs))
  ∎

rev-inv : ∀ xs → rev (rev xs) ≡ xs
rev-inv [] =
  begin
    rev (rev [])
  ≡⟨⟩
    []
  ∎
rev-inv (x ∷ xs) =
  begin
    rev (rev (x ∷ xs))
  ≡⟨⟩
    rev (rev xs ++ [ x ])
  ≡⟨ rev-++ (rev xs) [ x ] ⟩
    rev [ x ] ++ rev (rev xs)
  ≡⟨ cong (rev [ x ] ++_) (rev-inv xs) ⟩
    rev [ x ] ++ xs
  ≡⟨⟩
    x ∷ xs
  ∎

revAll : ∀ (P : A → Set) → ∀ {xs} → All P xs → All P (rev xs)
revAll P [] = []
revAll P (Px ∷ Pxs) =  revAll P Pxs ++All [ Px ]


module plfa-code.Induction where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; sym)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _∸_)
open import Function

open import plfa-code.Reasoning-legacy

_ : (3 + 4) + 5 ≡ 3 + (4 + 5)
_ =
  begin
    (3 + 4) + 5
  ≡⟨⟩
    7 + 5
  ≡⟨⟩
    12
  ≡⟨⟩
    3 + 9
  ≡⟨⟩
    3 + (4 + 5)
  ∎

+-assoc : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc zero n p =
  begin
    (zero + n) + p
  ≡⟨⟩
    n + p
  ≡⟨⟩
    zero + (n + p)
  ∎
+-assoc (suc m) n p =
  begin
    (suc m + n) + p
  ≡⟨⟩
    suc (m + n) + p
  ≡⟨⟩
    suc ((m + n) + p)
  ≡⟨ cong suc (+-assoc m n p) ⟩
    suc (m + (n + p))
  ≡⟨⟩
    suc m + (n + p)
  ∎

+-identityʳ : ∀ (m : ℕ) → m + zero ≡ m
+-identityʳ zero =
  begin
    zero + zero
  ≡⟨⟩
    zero
  ∎
+-identityʳ (suc m) =
  begin
    suc m + zero
  ≡⟨⟩
    suc (m + zero)
  ≡⟨ cong suc (+-identityʳ m)⟩
    suc m
  ∎

+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc zero n =
  begin
    zero + suc n
  ≡⟨⟩
    suc n
  ≡⟨⟩
    suc (zero + n)
  ∎
+-suc (suc m) n =
  begin
    suc m + suc n
  ≡⟨⟩
    suc (m + suc n)
  ≡⟨ cong suc (+-suc m n) ⟩
    suc (suc (m + n))
  ≡⟨⟩
    suc (suc m + n)
  ∎

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm zero n =
  begin
    zero + n
  ≡⟨⟩
    n
  ≡⟨ sym (+-identityʳ n) ⟩
    n + zero
  ∎
+-comm (suc m) n =
  begin
    suc m + n
  ≡⟨⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨ sym (+-suc n m) ⟩
    n + suc m
  ∎

+-rearrange : ∀ (m n p q : ℕ) → (m + n) + (p + q) ≡ m + (n + p) + q
+-rearrange m n p q =
  begin
    (m + n) + (p + q)
  ≡⟨ +-assoc m n (p + q) ⟩
    m + (n + (p + q))
  ≡⟨ cong (m +_) (sym (+-assoc n p q)) ⟩
    m + ((n + p) + q)
  ≡⟨ sym (+-assoc m (n + p) q) ⟩
    (m + (n + p)) + q
  ∎

+-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc′ zero n p = refl
+-assoc′ (suc m) n p rewrite +-assoc′ m n p = refl

-- practice

+-swap : ∀ (m n p : ℕ) → m + (n + p) ≡ n + (m + p)
+-swap m zero p = refl
+-swap m (suc n) p
  rewrite +-suc m (n + p)
  | sym (+-assoc m n p)
  | +-comm m n
  | +-assoc n m p = refl

*-distrib-+ : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-distrib-+ zero n p = refl
*-distrib-+ (suc m) n p rewrite *-distrib-+ m n p
                                | sym (+-assoc p (m * p) (n * p)) = refl

*-assoc : ∀ (m n p : ℕ) → (m * n) * p ≡ m * (n * p)
*-assoc zero n p = refl
*-assoc (suc m) n p rewrite *-distrib-+ n (m * n) p | *-assoc m n p = refl

*-zeroʳ : ∀ (n : ℕ) → n * zero ≡ zero
*-zeroʳ zero = refl
*-zeroʳ (suc n) rewrite *-zeroʳ n = refl

*-suc : ∀ (m n : ℕ) → m * suc n ≡ m * n + m
*-suc zero n = refl
*-suc (suc m) n =
  begin
    (suc m) * (suc n)
  ≡⟨⟩
    (suc n) + m * (suc n)
  ≡⟨ cong ((suc n) +_) (*-suc m n) ⟩
    suc n + (m * n + m)
  ≡⟨ +-swap (suc n) (m * n) m ⟩
    m * n + (suc n + m)
  ≡⟨ cong ((m * n) +_) (sym (+-suc n m)) ⟩
    m * n + (n + suc m)
  ≡⟨ sym (+-assoc (m * n) n (suc m)) ⟩
    m * n + n + suc m
  ≡⟨ cong (_+ (suc m)) (+-comm (m * n) n) ⟩
    (suc m) * n + (suc m)
  ∎

*-comm : ∀ (m n : ℕ) → m * n ≡ n * m
*-comm zero n rewrite *-zeroʳ n = refl
*-comm (suc m) n =
  begin
    suc m * n
  ≡⟨⟩
    n + m * n
  ≡⟨ +-comm n (m * n) ⟩
    m * n + n
  ≡⟨ cong (_+ n) (*-comm m n) ⟩
    n * m + n
  ≡⟨ sym (*-suc n m) ⟩
    n * suc m
  ∎

z∸n≡z : ∀ (n : ℕ) → zero ∸ n ≡ zero
z∸n≡z zero = refl
z∸n≡z (suc n) = refl

∸-+-assoc : ∀ (m n p : ℕ) → m ∸ n ∸ p ≡ m ∸ (n + p)
∸-+-assoc zero n p rewrite z∸n≡z n | z∸n≡z p | z∸n≡z (n + p) = refl
∸-+-assoc (suc m) zero p = refl
∸-+-assoc (suc m) (suc n) p rewrite ∸-+-assoc m n p = refl

---------- Bin ----------
data Bin : Set where
  nil : Bin
  x0_ : Bin → Bin
  x1_ : Bin → Bin

inc : Bin → Bin
inc nil    = x1 nil
inc (x0 t) = x1 t
inc (x1 t) = x0 (inc t)

to : ℕ → Bin
to zero    = x0 nil
to (suc n) = inc (to n)

from : Bin → ℕ
from nil      = 0
from (x0 t)   = 2 * (from t)
from (x1 t)   = suc (2 * (from t))
--------------------------------------

+1≡suc : ∀ {n : ℕ} → n + 1 ≡ suc n
+1≡suc {zero}   = refl
+1≡suc {suc n}  = cong suc +1≡suc

suc-from-inc : ∀ (x : Bin) → from (inc x) ≡ suc (from x)
suc-from-inc nil                                                        = refl
suc-from-inc (x0 x) rewrite +1≡suc {from x * 2}                         = refl
suc-from-inc (x1 x) rewrite suc-from-inc x | +-suc (from x) (from x + 0) = refl

-- t4 is ⊥ , because `to (from nil) ≡ x0 nil ≢ nil`
-- t4 : ∀ (x : Bin) → to (from x) ≡ x

from-to-const : ∀ (n : ℕ) → from (to n) ≡ n
from-to-const zero                                                  = refl
from-to-const (suc n) rewrite suc-from-inc (to n) | from-to-const n = refl


module Data.Nat where

import Prelude
import Data.Bool as Bool

open Prelude
open Bool

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

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN SUC suc #-}
{-# BUILTIN ZERO zero #-}

infix 40 _==_ _<_ _≤_ _>_ _≥_
infixl 60 _+_ _-_
infixl 70 _*_
infixr 80 _^_
infix 100 _!

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

_-_ : Nat -> Nat -> Nat
zero  - m     = zero
suc n - zero  = suc n
suc n - suc m = n - m

_*_ : Nat -> Nat -> Nat
zero  * m = zero
suc n * m = m + n * m

_^_ : Nat -> Nat -> Nat
n ^ zero  = 1
n ^ suc m = n * n ^ m

_! : Nat -> Nat
zero  ! = 1
suc n ! = suc n * n !

{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATMINUS _-_ #-}
{-# BUILTIN NATTIMES _*_ #-}

_==_ : Nat -> Nat -> Bool
zero  == zero  = true
zero  == suc _ = false
suc _ == zero  = false
suc n == suc m = n == m

_<_ : Nat -> Nat -> Bool
n     < zero  = false
zero  < suc m = true
suc n < suc m = n < m

_≤_ : Nat -> Nat -> Bool
n ≤ m = n < suc m

_>_ = flip _<_
_≥_ = flip _≤_

{-# BUILTIN NATEQUALS _==_ #-}
{-# BUILTIN NATLESS   _<_  #-}

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

modSuc : Nat -> Nat -> Nat
modSuc  zero   _ = zero
modSuc (suc n) m =
  ! n ≤ m  => suc n
  ! otherwise modSuc (n - m) m

{-# BUILTIN NATDIVSUC divSuc #-}
-- {-# BUILTIN NATMODSUC modSuc #-}

div : Nat -> Nat -> Nat
div n  zero   = zero
div n (suc m) = divSuc n m

mod : Nat -> Nat -> Nat
mod n  zero   = zero
mod n (suc m) = modSuc n m

gcd : Nat -> Nat -> Nat
gcd a 0 = a
gcd a b = gcd b (mod a b)

lcm : Nat -> Nat -> Nat
lcm a b = div (a * b) (gcd a b)

even : Nat -> Bool
even n = mod n 2 == 0

odd : Nat -> Bool
odd n = mod n 2 == 1


module PlfaInduction where
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_ ; refl ; cong ; sym)
open Eq.≡-Reasoning using (begin_ ; _≡⟨⟩_ ; _≡⟨_⟩_ ; _∎ )
open import Data.Nat using (ℕ ; zero ; suc ; _+_ ; _*_ ; _^_ )

+-assoc : ∀ (a b c : ℕ) → (a + b) + c ≡ a + (b + c)
+-assoc zero b c =
  begin
    (zero + b) + c
  ≡⟨⟩
    b + c
  ≡⟨⟩
    zero + (b + c)
  ∎

+-assoc (suc a) b c =
  begin
    (suc a + b) + c
  ≡⟨⟩
    suc (a + b) + c
  ≡⟨⟩
    suc ((a + b) + c)
  ≡⟨ cong suc (+-assoc a b c) ⟩
    suc (a + (b + c))
  ≡⟨⟩
    suc a + (b + c)
  ∎

+-identityʳ : ∀ (a : ℕ) → a + zero ≡ a
+-identityʳ zero =
  begin
    zero + zero
  ≡⟨⟩
    zero
  ∎

+-identityʳ (suc a) =
  begin
    suc a + zero
  ≡⟨⟩
    suc (a + zero)
  ≡⟨ cong suc (+-identityʳ a) ⟩
    suc a
  ∎

+-suc : ∀ (a b : ℕ) → a + suc b ≡ suc (a + b)
+-suc zero b =
  begin
    zero + suc b
  ≡⟨⟩
    suc b
  ≡⟨⟩
   suc (zero + b)
  ∎

+-suc (suc a) b =
  begin
    suc a + suc b
  ≡⟨⟩
    suc (a + suc b)
  ≡⟨ cong suc (+-suc a b) ⟩
    suc (suc a + b)
  ∎

+-comm : ∀ (a b : ℕ) → a + b ≡ b + a
+-comm zero b =
  begin
    zero + b
  ≡⟨⟩
    b
  ≡⟨ sym (+-identityʳ b) ⟩
    b + zero
  ∎

+-comm (suc a) b =
  begin
    suc a + b
  ≡⟨⟩
    suc (a + b)
  ≡⟨ cong suc (+-comm a b) ⟩
    suc (b + a)
  ≡⟨ sym (+-suc b a) ⟩
    b + suc a
  ∎

+-rearrange : ∀ (a b c d : ℕ) → (a + b) + (c + d)  ≡ (a + (b + c)) + d
+-rearrange a b c d =
  begin
    -- Because addition associates to the left
    -- a + b + (c + d)
    -- is the same as
    (a + b) + (c + d)
  ≡⟨ +-assoc a b (c + d) ⟩
    a + (b + (c + d))
  -- Lesson: The + and the _ in in (a +_) MUST be next to each other (no spaces allowed)
  ≡⟨ cong (a +_) (sym (+-assoc b c d)) ⟩
    a + ((b + c) + d)
  ≡⟨ sym (+-assoc a (b + c) d) ⟩
    (a + (b + c)) + d
  ∎

-- Let's do it again, now using the rewrite magic
--+-assoc' : ∀ (a b c : ℕ) → a + b + c ≡ a + (b + c)
--+-assoc' zero b c = refl
--+-assoc' (suc a) b c rewrite +-assoc' a b c = refl

--+-suc' : ∀ (a b : ℕ) → a + suc b ≡ suc (a + b)
--+-suc' zero b = refl
--+-suc' (suc a) b rewrite +-suc' a b = refl

+-swap : ∀ (a b c : ℕ) → a + (b + c) ≡ b + (a + c)
+-swap a b c rewrite sym (+-assoc a b c) | +-comm a b | +-assoc b a c = refl

*-zero : ∀ (a : ℕ) → a * zero ≡ zero
*-zero zero = refl
*-zero (suc a) rewrite *-zero a = refl

*-rsucdist : ∀ (n m : ℕ) → n * suc m ≡ n + n * m
*-rsucdist zero m = refl
*-rsucdist (suc n) m rewrite *-rsucdist n m | +-swap m n (n * m) = refl

*-distrib : ∀ (x b c : ℕ) → (b + c) * x ≡ b * x + c * x
*-distrib zero b c rewrite *-zero (b + c) | *-zero b | *-zero c = refl
*-distrib (suc x) b c rewrite *-rsucdist (b + c) x
                            | *-distrib x b c
                            | +-rearrange b c (b * x) (c * x)
                            | +-comm c (b * x)
                            | sym (+-rearrange b (b * x) c (c * x) )
                            | sym (*-rsucdist b x)
                            | sym (*-rsucdist c x) = refl

*-assoc : ∀ (a b c : ℕ) → (a * b) * c ≡ a * (b * c)
*-assoc zero b c = refl
*-assoc (suc a) b c =
  begin
    (suc a * b) * c
  ≡⟨⟩
    (b + a * b) * c
  ≡⟨ *-distrib c b (a * b) ⟩
    b * c + (a * b) * c
  ≡⟨ cong (λ { x → b * c + x }) (*-assoc a b c) ⟩
    suc a * (b * c)
  ∎

*-comm : ∀ (a b : ℕ) → a * b ≡ b * a
*-comm zero b rewrite *-zero b = refl
*-comm (suc a) b rewrite *-comm a b | sym (*-rsucdist b a) = refl

infixl 6 _∸_
_∸_ : ℕ → ℕ → ℕ
m ∸ zero = m
zero ∸ (suc n) = zero
(suc m) ∸ (suc n) = m ∸ n

∸-zero : ∀ (a : ℕ) → zero ∸ a ≡ zero
∸-zero zero = refl
∸-zero (suc a) = refl

∸-suc : ∀ (a b : ℕ) → a ∸ suc b ≡ a ∸ 1 ∸ b
∸-suc zero b rewrite ∸-zero b = refl
∸-suc (suc a) b = refl

-- ∸-+-assoc : ∀ (a b c : ℕ) → a ∸ b ∸ c ≡ a ∸ (b + c)
-- ∸-+-assoc a zero c = refl
-- ∸-+-assoc a (suc b) c =
--   begin
--     a ∸ suc b ∸ c
--   ≡⟨ cong (λ x → x ∸ c) (∸-suc a b) ⟩
--     a ∸ 1 ∸ b ∸ c -- Remember this is equal to ((a ∸ 1) ∸ b) ∸ c
--   ≡⟨ ∸-+-assoc  ⟩
--   ≡⟨ ∸-suc a (b + c) ⟩
--     a ∸ (b + c)
--   ∎


{-

Based on Nicolai Kraus' blog post:
  The Truncation Map |_| : ℕ -> ‖ℕ‖ is nearly Invertible
  https://homotopytypetheory.org/2013/10/28/the-truncation-map-_-ℕ-‖ℕ‖-is-nearly-invertible/

Defines [recover], which definitionally satisfies `recover ∣ x ∣ ≡ x` ([recover∣∣]) for homogeneous types

Also see the follow-up post by Jason Gross:
  Composition is not what you think it is! Why “nearly invertible” isn’t.
  https://homotopytypetheory.org/2014/02/24/composition-is-not-what-you-think-it-is-why-nearly-invertible-isnt/

-}
{-# OPTIONS --cubical --safe #-}

module Cubical.HITs.PropositionalTruncation.MagicTrick where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Path
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Pointed.Homogeneous

open import Cubical.HITs.PropositionalTruncation.Base
open import Cubical.HITs.PropositionalTruncation.Properties

module Recover {ℓ} (A∙ : Pointed ℓ) (h : isHomogeneous A∙) where
  private
    A = typ A∙
    a = pt A∙

  toEquivPtd : ∥ A ∥ → Σ[ B∙ ∈ Pointed ℓ ] (A , a) ≡ B∙
  toEquivPtd = recPropTrunc (isContr→isProp (_ , λ p → contrSingl (snd p)))
                            (λ x → (A , x) , h x)
  private
    B∙ : ∥ A ∥ → Pointed ℓ
    B∙ tx = fst (toEquivPtd tx)

  -- the key observation is that B∙ ∣ x ∣ is definitionally equal to (A , x)
  private
    obvs : ∀ x → B∙ ∣ x ∣ ≡ (A , x)
    obvs x = refl -- try it: `C-c C-n B∙ ∣ x ∣` gives `(A , x)`

  -- thus any truncated element (of a homogeneous type) can be recovered by agda's normalizer!

  recover : ∀ (tx : ∥ A ∥) → typ (B∙ tx)
  recover tx = pt (B∙ tx)

  recover∣∣ : ∀ (x : A) → recover ∣ x ∣ ≡ x
  recover∣∣ x = refl -- try it: `C-c C-n recover ∣ x ∣` gives `x`

  private
    -- notice that the following typechecks because typ (B∙ ∣ x ∣) is definitionally equal to to A, but
    --  `recover : ∥ A ∥ → A` does not because typ (B∙ tx) is not definitionally equal to A (though it is
    --  judegmentally equal to A by cong typ (snd (toEquivPtd tx)) : A ≡ typ (B∙ tx))
    obvs2 : A → A
    obvs2 = recover ∘ ∣_∣

    -- one might wonder if (cong recover (squash ∣ x ∣ ∣ y ∣)) therefore has type x ≡ y, but thankfully
    --  typ (B∙ (squash ∣ x ∣ ∣ y ∣ i)) is *not* A (it's a messy hcomp involving h x and h y)
    recover-squash : ∀ x y → -- x ≡ y -- this raises an error
                             PathP (λ i → typ (B∙ (squash ∣ x ∣ ∣ y ∣ i))) x y
    recover-squash x y = cong recover (squash ∣ x ∣ ∣ y ∣)

-- Demo, adapted from:
-- https://bitbucket.org/nicolaikraus/agda/src/e30d70c72c6af8e62b72eefabcc57623dd921f04/trunc-inverse.lagda

private
  open import Cubical.Data.Nat
  open Recover (ℕ , zero) (isHomogeneousDiscrete discreteℕ)

  -- only `∣hidden∣` is exported, `hidden` is no longer in scope
  module _ where
    private
      hidden : ℕ
      hidden = 17

    ∣hidden∣ : ∥ ℕ ∥
    ∣hidden∣ = ∣ hidden ∣

  -- we can still recover the value, even though agda can no longer see `hidden`!
  test : recover ∣hidden∣ ≡ 17
  test = refl -- try it: `C-c C-n recover ∣hidden∣` gives `17`
              --         `C-c C-n hidden` gives an error

  -- Finally, note that the definition of recover is independent of the proof that A is homogeneous. Thus we
  --  still can definitionally recover information hidden by ∣_∣ as long as we permit holes. Try replacing
  --  `isHomogeneousDiscrete discreteℕ` above with a hole (`?`) and notice that everything still works


module nat-to-string where

open import bool
open import char
open import eq
open import list
open import maybe
open import nat
open import nat-division
open import nat-thms
open import product
open import string
open import termination

ℕ-to-digitsh : (base : ℕ) → 1 < base ≡ tt → (x : ℕ) → ↓𝔹 _>_ x → 𝕃 ℕ
ℕ-to-digitsh _ _ 0 _ = []
ℕ-to-digitsh base bp (suc x) (pf↓ fx) with (suc x) ÷ base ! (<=ℕff2 base bp)
... | q , r , p , _ = r :: (ℕ-to-digitsh base bp q (fx (÷<{base}{q}{r}{x} bp p)))

ℕ-to-digits : ℕ → 𝕃 ℕ
ℕ-to-digits x = reverse (ℕ-to-digitsh 10 refl x (↓-> x))

digit-to-string : ℕ → string
digit-to-string 0 = "0"
digit-to-string 1 = "1"
digit-to-string 2 = "2"
digit-to-string 3 = "3"
digit-to-string 4 = "4"
digit-to-string 5 = "5"
digit-to-string 6 = "6"
digit-to-string 7 = "7"
digit-to-string 8 = "8"
digit-to-string 9 = "9"
digit-to-string _ = "unexpected-digit"

digits-to-string : 𝕃 ℕ → string
digits-to-string [] = ""
digits-to-string (d :: ds) = (digit-to-string d) ^ (digits-to-string ds)

ℕ-to-string : ℕ → string
ℕ-to-string 0 = "0"
ℕ-to-string (suc x) = digits-to-string (ℕ-to-digits (suc x))

string-to-digit : char → maybe ℕ
string-to-digit '0' = just 0
string-to-digit '1' = just 1
string-to-digit '2' = just 2
string-to-digit '3' = just 3
string-to-digit '4' = just 4
string-to-digit '5' = just 5
string-to-digit '6' = just 6
string-to-digit '7' = just 7
string-to-digit '8' = just 8
string-to-digit '9' = just 9
string-to-digit _ = nothing

-- the digits are in order from least to most significant
digits-to-ℕh : ℕ → ℕ → 𝕃 ℕ → ℕ
digits-to-ℕh multiplier sum [] = sum
digits-to-ℕh multiplier sum (x :: xs) = digits-to-ℕh (10 * multiplier) (x * multiplier + sum) xs

digits-to-ℕ : 𝕃 ℕ → ℕ
digits-to-ℕ digits = digits-to-ℕh 1 0 digits

string-to-ℕ : string → maybe ℕ
string-to-ℕ s with 𝕃maybe-map string-to-digit (reverse (string-to-𝕃char s))
... | nothing = nothing
... | just ds = just (digits-to-ℕ ds)


-- Exercises for session 2
--
-- If unsure which exercises to do start with those marked with *
--
{-# OPTIONS --cubical --allow-unsolved-metas #-}
module ExerciseSession2 where

open import Part1
open import Part2
open import ExerciseSession1

open import Cubical.Foundations.Equiv

-- Exercises about Part 2:

-- Exercise* 1: prove that the computation rule for J on refl
-- holds up to a path.
-- (hint: normalize the goal using C-u C-u C-c C-,)
JEq : {x : A} (P : (z : A) → x ≡ z → Type ℓ'')
      (d : P x refl) → J P d refl ≡ d
JEq P p d = {!!}

-- Exercise* 2: prove that isContr implies isProp
isContr→isProp : isContr A → isProp A
isContr→isProp = {!!}

-- Exercise 3: prove that isProp implies isProp'
-- (hint: use isProp→isSet from the Part2)
isProp→isProp' : isProp A → isProp' A
isProp→isProp' = {!!}

-- Exercise 4: prove the following lemma
-- (hint: use the solutions to exercises 2 and 3)
isContr→isContr≡ : isContr A → (x y : A) → isContr (x ≡ y)
isContr→isContr≡ = {!!}

-- Exercise 5: use transp to turn a PathP into a transport
fromPathP : {A : I → Type ℓ} {x : A i0} {y : A i1}
          → PathP A x y
          → transport (λ i → A i) x ≡ y
fromPathP {A = A} p i = {!!}

-- The converse is harder to prove so we give it:
toPathP : {A : I → Type ℓ} {x : A i0} {y : A i1}
        → transport (λ i → A i) x ≡ y
        → PathP A x y
toPathP {A = A} {x = x} p i =
  hcomp (λ j → λ { (i = i0) → x
                 ; (i = i1) → p j })
        (transp (λ j → A (i ∧ j)) (~ i) x)

-- Exercise* 6: prove that two Σ-types where the second component is a
-- proposition is equal if the first projections are equal.
-- (hint: use ΣPathP and toPathP)
Σ≡Prop : {B : A → Type ℓ'} {u v : Σ A B} (h : (x : A) → isProp (B x))
       → (p : fst u ≡ fst v) → u ≡ v
Σ≡Prop {B = B} {u = u} {v = v} h p = {!!}

-- Exercice 7 (harder): prove that being contractible is a proposition.
-- (hint: the second component can be given by a suitable higher
-- dimensional hcomp)
isPropIsContr : isProp (isContr A)
isPropIsContr = {!!}

-- Exercises about Part 3:

-- Exercise* 8: compose sucPathInt with itself n times. Transporting
-- along this will be addition, transporting with it backwards will be
-- subtraction.

open import Cubical.Data.Nat
open import Cubical.Data.Int hiding (addEq ; subEq)

-- a) Define a path "addEq n" by composing sucPathInt with itself n times.
addEq : ℕ → Int ≡ Int
addEq n = {!!}

-- b) Define another path "subEq n" by composing "sym sucPathInt" with
-- itself n times.
subEq : ℕ → Int ≡ Int
subEq n = {!!}

-- c) Define addition on integers by pattern-matching and transporting
-- along addEq/subEq appropriately.
_+Int_ : Int → Int → Int
m +Int n = {!!}

-- d) Do some concrete computations using _+Int_ (this would not work
-- in HoTT as the transport would be stuck!)

-- e) Use isEquivTransport from

open import Cubical.Foundations.Transport

-- to prove that +Int with a fixed number is an equivalence.
--
-- Note that proving this for the usual _+_ function would be a lot
-- longer, but now we get it for free as addition is defined using
-- transport which we already know is an equivalence.

-- Exercise* 9 (harder): prove that hSet is not a set

-- Let's import Bool instead so that we get it from the library
open import Cubical.Data.Bool renaming (notEq to notPath)

-- The empty type ⊥ (written \bot)
open import Cubical.Data.Empty

-- Just define hSets of level 0 for simplicity
hSet : Type₁
hSet = Σ[ A ∈ Type₀ ] isSet A

-- Bool is an hSet
BoolSet : hSet
BoolSet = Bool , isSetBool

-- (hint: use a suitable nested transport)
notPath≢refl : (notPath ≡ refl) → ⊥
notPath≢refl e = true≢false {!!}

-- (hint: use notPath≢refl and define two elements of BoolSet ≡
-- BoolSet, one based on notPath and one based on refl. Σ≡Prop and
-- isPropIsSet is probably handy)
¬isSet-hSet : isSet hSet → ⊥
¬isSet-hSet h = {!!}

-- Exercise 10 (more work): prove that FinData and Fin are equivalent
-- and hence equal. Transport some functions and proofs between the
-- two.

-- Orderings on ℕ
open import Cubical.Data.Nat.Order

data FinData : ℕ → Type₀ where
  zero : {n : ℕ} → FinData (suc n)
  suc  : {n : ℕ} (i : FinData n) → FinData (suc n)

Fin : ℕ → Type₀
Fin n = Σ[ k ∈ ℕ ] k < n


module relations where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm; +-identityʳ)

data _≤_ : ℕ → ℕ → Set where
  z≤n : ∀ {n : ℕ} → zero ≤ n
  s≤s : ∀ {m n : ℕ} → m ≤ n → suc m ≤ suc n

infix 4 _≤_

foo : 2 ≤ 4
foo = s≤s (s≤s z≤n)

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

bar : 1 ≤ 3
bar = inv-s≤s foo


module z03-natural-numbers where

open import bool
open import bool-thms using (𝔹-contra)
open import eq
open import level

-- p 50

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

-- p 51

{-# BUILTIN NATURAL ℕ #-}

-------------------------
_+_ : ℕ → ℕ → ℕ
zero  + n =          n
suc m + n = suc (m + n) -- recursive call on structurally smaller left side 'm' -- termination

-- p 53

-------------------------
0+ : ∀ (x : ℕ)
   → 0 + x ≡ x
0+ _ = refl -- via definitional equality

{- fails because _+_ defined in terms of pattern matching on left arg
+0 : ∀ (x : ℕ)
    → x + 0 ≡ x
+0 _ = refl

-- p 55

solution is for proof to call itself recursively:
-------------------------
-}
+0 : ∀ (x : ℕ)
   → x + 0 ≡ x

-- BASE
+0  zero                = refl -- via definitional equality

-- INDUCTIVE
-- note: name of 'y' variable, if renamed to 'x', is not same as 'x' in signature
+0 (suc y) rewrite +0 y = refl
{-    ^
      |
'x' in sig instantiated to 'suc y'

so trying to prove (the goal) : suc y + 0 ≡ suc y

goal can be simplified by inductive case of def of _+_

so goal definitionally equal to : suc (y + 0) ≡ suc y

       rewrite recursive call proves   y + 0  ≡     y

  type of proof is x + 0 ≡ x
  so Agda with replace occurrences of x + 0 with x

                       leaving  : suc  y      ≡ suc y

-- p 57

PROOF BY INDUCTION: recursive proofs

------------------------------------------------------------------------------
+ ASSOCIATIVITY

When theorem has multiple variables, must decide which one to use for induction.
Generally: var used where a recursive fun will patten match on it.
If several vars are pattern matched, prefer the one that is matched the most.

Since _+_ matches on 1st arg, then do induction here on 1st arg.
Here 'x' is matched twice but 'y' only once -- so use 'x'.
-}

-------------------------
+assoc : ∀ (x y z : ℕ)
       →  x + (y  + z)
       ≡ (x +  y) + z
{-
BASE case
  goal: zero + (y + z) ≡ (zero + y) + z
  via def/eq
-}
+assoc  zero   y z                      = refl

{-
INDUCTIVE case
  goal          : suc (x + (y + z)) ≡ suc ((x + y) + z)
  need proof of :     (x + (y + z)) ≡     ((x + y) + z)
    that is exactly the inductive hypotheses
    so use rewrite to recursively apply the proof
-}
+assoc (suc x) y z rewrite +assoc x y z = refl

------------------------------------------------------------------------------
-- p 60 + COMMUTATIVITY (rewrite with multiple equations)

-------------------------
+suc : ∀ (x y : ℕ) → x + (suc y) ≡ suc (x + y)
+suc  zero   y                  = refl
+suc (suc x) y rewrite +suc x y = refl

-------------------------
+comm : ∀ (x y : ℕ) → x + y ≡ y + x
{-
BASE
 Goal:         : y ≡ (y + zero)
 so rewrite right hand side using +0 proof
 simplifies to : y ≡  y
-}
+comm  zero   y rewrite +0 y = refl
{-
INDUCTIVE
 Goal : suc (x + y) ≡ (y + suc x)
-}
+comm (suc x) y rewrite +suc y x | +comm x y = refl

------------------------------------------------------------------------------
-- p 62 MULTIPLICATION

-------------------------
_*_ : ℕ → ℕ → ℕ
zero  * n = zero
suc m * n = n + (m * n)

-------------------------
-- p 63 - right distributivity of * over +

-- variable counts x : 2; y : 1; z : 0 : so use x

*distribr : ∀ (x y z : ℕ)
          → (x + y) * z ≡ (x * z) + (y * z)

-- BASE
*distribr  zero   y z = refl

{-
INDUCTIVE
Goal:  ((suc x + y) * z)   ≡ ((suc x * z)  + (y * z))
Goal: (z + ((x + y) * z)) ≡ ((z + (x * z)) + (y * z))

*distribr (suc x) y z rewrite *distribr x y z = {!!}
Goal: (z + ((x * z) + (y * z))) ≡ ((z + (x * z)) + (y * z))
      right-associated                left-associated
so reassociate: to prove
A + (B + C) ≡ (A + B) + C
^    ^   ^
|    |   |
z    |   |
   x * z |
       y * z
-}
*distribr (suc x) y z
  rewrite
    *distribr x y z
  = +assoc z (x * z) (y * z)

------------------------------------------------------------------------------
-- p 65 * COMMUTATIVITY

-------------------------
*0 : ∀ (x : ℕ)
   → x * 0 ≡ 0

-- BASE
*0 zero = refl -- def/eq : (zero * 0) ≡ 0
{-
INDUCTIVE
(suc x * 0) ≡ 0
    (x * 0) ≡ 0 -- IH
rewrite
         0  ≡ 0
-}
*0 (suc y) rewrite *0 y = refl

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

*suc : ∀ (x y : ℕ) → x * (suc y) ≡ x + (x * y)
{-
BASE
         (zero * suc y) ≡ (zero + (zero * y))
def/eq    zero          ≡  zero
-}
*suc zero y = refl
{-
INDUCTIVE
                (suc x *   suc y)   ≡ (suc   x +   (suc x * y))
def/eq    suc  (y + (x *   suc y))  ≡  suc  (x + (y  + (x * y)))
rw *suc   suc  (y + (x  + (x * y))) ≡  suc  (x + (y  + (x * y)))
rw +assoc suc ((y +  x) + (x * y))  ≡  suc  (x + (y  + (x * y)))
rw +assoc suc ((y +  x) + (x * y))  ≡  suc ((x +  y) + (x * y))
rw +comm  suc ((x +  y) + (x * y))  ≡  suc ((x +  y) + (x * y))
-}
*suc (suc x) y
  rewrite
    *suc   x y
  | +assoc y x (x * y)
  | +assoc x y (x * y)
  | +comm  y x = refl

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

*comm : ∀ (x y : ℕ) → x * y ≡ y * x
{-
BASE
             (zero * y) ≡ (y * zero)
def/eq        zero      ≡ (y * zero)
rs *0         zero      ≡      zero
-}
*comm zero y rewrite *0 y = refl
{-
INDUCTIVE
           (suc x * y)  ≡ (y *  suc x)
def/eq    (y + (x * y)) ≡ (y *  suc x)
rw *suc   (y + (x * y)) ≡ (y + (y * x))
rw *comm  (y + (y * x)) ≡ (y + (y * x))
-}
*comm (suc x) y
  rewrite
    *suc  y x
  | *comm x y = refl

------------------------------------------------------------------------------
-- p 66 * ASSOCIATIVITY

*assoc : ∀ (x y z : ℕ) → x * (y * z) ≡ (x * y) * z
{-
BASE
        (zero * (y * z)) ≡ ((zero * y) * z)
def/eq   zero            ≡   zero
-}
*assoc  zero   y z = refl
{-
INDUCTIVE

                      (suc x *  (y  * z))  ≡        ((suc x * y)  * z)
def/eq        ((y * z) +  (x *  (y  * z))) ≡ ((y      +  (x * y)) * z)
rw *distribr  ((y * z) +  (x *  (y  * z))) ≡ ((y * z) + ((x * y)  * z))
rw *assoc     ((y * z) + ((x *   y) * z))  ≡ ((y * z) + ((x * y)  * z))
-}
*assoc (suc x) y z
  rewrite
    *distribr y (x * y) z
  | *assoc x y z = refl

------------------------------------------------------------------------------
-- p 67 LESS-THEN <

_<_ : ℕ → ℕ → 𝔹
0       <      0  = ff
0       < (suc y) = tt
(suc x) < (suc y) = x < y
(suc x) <      0  = ff

-------------------------
-- < is TRANSITIVE

{-
xx : ∀ {x y z : ℕ}
   → x < y
   → y < z
   → x < z

Above will not type check because _<_ returns 𝔹 VALUE, not a type
Types have type Set in Agda -- 𝔹 is not the same as Set.
Could define _<_ as a relation: ℕ → ℕ → Set.
But then _<_ could not be used computationally.
Expressions with type Set describe code -- they are NOT code themselves
- e.g., cannot pattern-match on expressions of type Set
        cannot compute with them
Transitivity theorem is statement about behavior of the PROGRAM _<_.
-}

-- p 69

-------------------------
<-0 : ∀ (x : ℕ) → x < 0 ≡ ff
<-0      0  = refl --  (zero < 0) ≡ ff; ff ≡ ff
<-0 (suc y) = refl -- (suc y < 0) ≡ ff; ff ≡ ff

-------------------------
<-trans : ∀ {x y z : ℕ}
        → x < y ≡ tt
        → y < z ≡ tt
        → x < z ≡ tt
{-
       p1 : (x < zero) ≡ tt    ; p2 : (zero < z) ≡ tt      = Goal: (x < z) ≡ tt
rw <-0 p1 : ff         ≡ tt    ; p2 : (0    < z) ≡ tt      = Goal: (x < z) ≡ tt
-}
<-trans     {x}     {0}         p1 p2 rewrite <-0 x = 𝔹-contra p1

-- can't be called like this so no proof needed
<-trans     {0} {suc y}     {0} p1 ()

--     p1 : (zero < suc y) ≡ tt ; p2 : (suc y < suc z) ≡ tt = Goal: (zero < suc z) ≡ tt
<-trans     {0} {suc y} {suc z} p1 p2 = refl

-- can't be called like this so no proof needed
<-trans {suc x} {suc y}     {0} p1 ()

--     p1 : (suc x < suc y) ≡ tt; p2 : (suc y < suc z) ≡ tt = Goal: (suc x < suc z) ≡ tt
<-trans {suc x} {suc y} {suc z} p1 p2 = <-trans {x} {y} {z} p1 p2 -- uses IH via recursive call

------------------------------------------------------------------------------
-- p 71 EQUALITY TEST for ℕ
{-
so far, rely on
- def/eq : done automatically during type checking
- ≡      : express, as a TYPE, a proposition that two VALUES are equal

there are other kinds of equality, e,g.,

COMPUTATIONAL EQUALITY : tests VALUE equality
-}

_=ℕ_ : ℕ → ℕ → 𝔹
0     =ℕ     0 = tt
suc x =ℕ suc y = x =ℕ y
_     =ℕ     _ = ff

_≤_  : ℕ → ℕ → 𝔹
x ≤ y = (x < y) || x =ℕ y

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

=ℕ-refl : ∀ (x : ℕ) → (x =ℕ x) ≡ tt
=ℕ-refl 0 = refl
=ℕ-refl (suc x) = (=ℕ-refl x)

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

-- SOUNDNESS property: things indicated to be true really are true
=ℕ-to-≡ : ∀ {x y : ℕ} → x =ℕ y ≡ tt → x ≡ y
=ℕ-to-≡     {0}     {0} _ = refl
=ℕ-to-≡ {suc x}     {0} ()
=ℕ-to-≡     {0} {suc y} ()
=ℕ-to-≡ {suc x} {suc y} p
  rewrite
    =ℕ-to-≡ {x} {y} p = refl

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

=ℕ-from-≡ : ∀ {x y : ℕ}
          → x ≡ y
          → x =ℕ y ≡ tt
=ℕ-from-≡ {x} refl = =ℕ-refl x

------------------------------------------------------------------------------
-- p 73 EXERCISES

-- 1 nat-thms

--------------------------------------------------
-- properties of addition
--------------------------------------------------

+1 : ∀ (x : ℕ) → x + 1 ≡ suc x
+1 zero = refl
+1 (suc n) rewrite +1 n = refl

+perm : ∀ (x y z : ℕ) → x + (y + z) ≡ y + (x + z)
+perm zero y z = refl
+perm (suc x) y z -- (suc  x + (y + z)) ≡ (y + (suc  x + z))
                  --  suc (x + (y + z)) ≡ (y +  suc (x + z))
  rewrite
    +suc y (x + z) -- suc (x + (y + z)) ≡ suc (y + (x + z))
  | +assoc x y z   -- suc ((x + y) + z) ≡ suc (y + (x + z))
  | +comm x y      -- suc ((y + x) + z) ≡ suc (y + (x + z))
  | +assoc y x z   -- suc ((y + x) + z) ≡ suc ((y + x) + z)
  = refl

--------------------------------------------------
-- properties of multiplication
--------------------------------------------------

*1 : ∀ {n : ℕ} → n * 1 ≡ n
*1 {zero} = refl
*1 {suc n}    -- (suc n * 1) ≡ suc n
              -- suc (n * 1) ≡ suc n
  rewrite
    *comm n 1 -- suc (n + 0) ≡ suc n
  | +0 n      -- suc  n      ≡ suc n
  = refl

--------------------------------------------------
-- properties of <, ≤, and =ℕ, iszero
--------------------------------------------------

0-≤ : ∀ (x : ℕ) → 0 ≤ x ≡ tt
0-≤ zero = refl
0-≤ (suc n)      -- (0 ≤ suc n) ≡ tt
  rewrite 0-≤ n  --          tt ≡ tt
  = refl

=ℕ-sym : ∀ (x y : ℕ) → (x =ℕ y) ≡ (y =ℕ x)
=ℕ-sym zero zero  = refl
=ℕ-sym (suc x) zero = refl -- (suc x =ℕ zero) ≡ (zero =ℕ suc x);  ff ≡ ff
=ℕ-sym zero (suc y) = refl -- (zero =ℕ suc y) ≡ (suc y =ℕ zero);  ff ≡ ff
=ℕ-sym (suc x) (suc y) rewrite =ℕ-sym x y = refl

=ℕ-suc : ∀ (x : ℕ) → suc x =ℕ x ≡ ff
=ℕ-suc zero = refl
=ℕ-suc (suc n) rewrite =ℕ-suc n = refl

<-suc : ∀ (n : ℕ) → n < suc n ≡ tt
<-suc zero = refl
<-suc (suc n) rewrite <-suc n = refl

-- TODO: understand
suc-inj : ∀ {n m : ℕ} → suc n ≡ suc m → n ≡ m
suc-inj         {0}  {0} _ = refl
suc-inj {m = suc m} refl   = refl

<=ℕff : ∀ (x : ℕ) → 0 < x ≡ tt → x =ℕ 0 ≡ ff
<=ℕff (suc x) _ = refl

<≤ : ∀ {n m : ℕ} → n < m ≡ tt → n ≤ m ≡ tt
<≤     {0}     {0} _ = refl
<≤ {suc _}     {0} ()
<≤     {0} {suc _} _ = refl
<≤ {suc n} {suc m} p rewrite <≤ {n} {m} p = refl

--------------------------------------------------
-- ordering properties of < and ≤ℕ
--------------------------------------------------

<-irrefl : ∀ (n : ℕ) → n < n ≡ ff
<-irrefl zero = refl
<-irrefl (suc n) rewrite <-irrefl n = refl

<-asym : ∀ {x y : ℕ}
       → x < y ≡ tt
       → y < x ≡ ff
<-asym {0}         {0} _ = refl
<-asym {0}     {suc _} _ = refl
<-asym {suc _}     {0}     ()
<-asym {suc x} {suc y} p = <-asym {x} {y} p

ℕ-trichotomy𝔹 : ∀ (n m : ℕ) → n < m || n =ℕ m || m < n ≡ tt
ℕ-trichotomy𝔹      0       0  = refl
ℕ-trichotomy𝔹      0  (suc m) = refl
ℕ-trichotomy𝔹 (suc n)      0  = refl
ℕ-trichotomy𝔹 (suc n) (suc m) = ℕ-trichotomy𝔹 n m

<≤-trans : ∀ {x y z : ℕ}
         → x < y ≡ tt
         → y ≤ z ≡ tt
         → x < z ≡ tt
<≤-trans     {x}     {0}         p1 _  rewrite <-0 x = 𝔹-contra p1
<≤-trans     {0} {suc y}     {0} _  ()
<≤-trans     {0} {suc y} {suc z} _  _  = refl
<≤-trans {suc x} {suc y}     {0} _  ()
<≤-trans {suc x} {suc y} {suc z} p1 p2 = <≤-trans {x} {y} {z} p1 p2

≤-refl : ∀ (x : ℕ) → x ≤ x ≡ tt
≤-refl zero = refl
≤-refl (suc x) rewrite ≤-refl x = refl

--------------------------------------------------
-- injectivity properties of addition
--------------------------------------------------

+inj1 : ∀ {x y z : ℕ}
      → x + y ≡ x + z
      →     y ≡     z
+inj1 {0} {y} {z} p = p
+inj1 {suc x} {y} {z} p = +inj1 {x} {y} {z} (suc-inj p)

+inj2 : ∀ {x y z : ℕ}
      → x + z ≡ y + z
      → x     ≡ y
+inj2 {x} {y} {z} p        -- p : (x + z) ≡ (y + z); Goal: x ≡ y
  rewrite
    +comm x z              -- p : (z + x) ≡ (y + z); Goal: x ≡ y
  | +comm y z              -- p : (z + x) ≡ (z + y); Goal: x ≡ y
  = +inj1 {z} {x} {y} p    -- NOTE: '+inj1'

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

-- 2

{- TODO
nat.agda

>, >= : defined in terms of < and <=

Prove versions of theorems like <-trans and <+
- modified to use _>_ instead of _<_

for practice writing out formulas in Agda
since the proofs can be written just to invoke the theorems dealing with _<_
-}

_>_ : ℕ → ℕ → 𝔹
a > b = b < a

_≥_ : ℕ → ℕ → 𝔹
a ≥ b = b ≤ a

<-trans2 : ∀ {x y z : ℕ}
         → y > x ≡ tt
         → z > y ≡ tt
         → z > x ≡ tt
<-trans2 {x} {y} {z} = <-trans {x} {y} {z}

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

-- 3a

f : (n : ℕ) → ℕ
f      0  = 1
f (suc x) = (suc x) * (f x)

f-is-factorial : f 5 ≡ 120
f-is-factorial = refl

-- 3b

f' : ℕ → 𝔹
fb : ℕ → 𝔹

-- is-odd
f'      0  = ff
f' (suc x) = fb x

-- is-even
fb      0  = tt
fb (suc x) = f' x

f'-is-odd : f' (suc 0) ≡ tt
f'-is-odd = refl

fb-is-even : fb (suc (suc 0)) ≡ tt
fb-is-even = refl


module Misc.PosBinary where  -- Positive Binary Numbers

open import Data.Nat
open import Data.List
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym)

open import Induction.WellFounded
open import Induction.Nat using (<-well-founded)

data Bin+ : Set where
  [] : Bin+
  1∷_ : Bin+ → Bin+
  2∷_ : Bin+ → Bin+

decimal : Bin+ → ℕ
decimal [] = 0
decimal (1∷ xs) = 1 + 2 * decimal xs
decimal (2∷ xs) = 2 + 2 * decimal xs

-- A even/odd view. Surprised that we don't have it in StdLib

data Div2 : ℕ → Set where
  even : ∀ n → Div2 (2 * n)
  odd  : ∀ n → Div2 (1 + 2 * n)

open import Data.Nat.Properties.Simple using (+-suc)
  -- +-suc : ∀ m n → m + suc n ≡ suc (m + n)
open import Data.Nat.Properties using (m≤′m+n)
  -- m≤′m+n : ∀ m n → m ≤′ m + n

_div2 : ∀ n → Div2 n
zero div2 = even 0
suc n div2 with n div2
suc .(n + (n + 0)) div2       | even n = odd n
suc .(suc (n + (n + 0))) div2 | odd n
      rewrite sym (+-suc n (n + zero)) = even (1 + n)

bin+' : (n : ℕ) → Acc _<′_ n → Bin+
bin+' n _ with n div2
bin+' .0 _                              | even zero = []
bin+' .(suc (m + suc (m + 0))) (acc rs) | even (suc m) =
   2∷ bin+' m (rs m (m≤′m+n (suc m) _))
bin+' .(suc (m + (m + 0)))     (acc rs) | odd m  =
   1∷ bin+' m (rs m (m≤′m+n (suc m) _))

bin+ : ℕ → Bin+
bin+ n = bin+' n (<-well-founded n)

{-  For reference.

bin' : (n : ℕ) → Acc _<′_ n → List ℕ
bin' n _ with n div2
bin' .0 (acc rs) | even 0 = []
bin' .(suc m + (suc m + 0)) (acc rs) | even (suc m) =
     0 ∷ bin' m (rs m (m≤′m+n (suc m) _))
bin' .(suc (m + (m + 0))) (acc rs)   | odd m =
     1 ∷ bin' m (rs m (m≤′m+n (suc m) _))

bin : ℕ → List ℕ
bin n = bin' n (<-well-founded n)
-}

lInv' : ∀ n → (ac : Acc _<′_ n) → decimal (bin+' n ac) ≡ n
lInv' n ac with n div2
lInv' .0 ac | even zero = refl
lInv' .(suc (m + suc (m + 0))) (acc rs) | even (suc m)
  rewrite lInv' m (rs m (m≤′m+n (suc m) (suc (m + zero))))
        | +-suc m (m + 0) = refl
lInv' .(suc (m + (m + 0))) (acc rs) | odd m
  rewrite lInv' m (rs m (m≤′m+n (suc m) (m + zero))) = refl

lInv : ∀ n → decimal (bin+ n) ≡ n
lInv n = lInv' n (<-well-founded n)


module Nats.Add.Comm where

open import Equality
open import Nats
open import Function

------------------------------------------------------------------------
-- internal stuffs

private

  a+0=0+a : ∀ a → a + 0 ≡ a
  a+0=0+a  zero   = refl
  a+0=0+a (suc a) = cong suc $ a+0=0+a a

  ++a+b=a+b++ : ∀ a b → suc (a + b) ≡ a + suc b
  ++a+b=a+b++  zero   b = refl
  ++a+b=a+b++ (suc a) b = cong suc $ ++a+b=a+b++ a b

  a+b=b+a : ∀ a b → a + b ≡ b + a
  a+b=b+a zero b = sym (a+0=0+a b)
  a+b=b+a (suc a) b = suc (a + b) ≡⟨ cong suc (a+b=b+a a b) ⟩ ++a+b=a+b++ b a

------------------------------------------------------------------------
-- public aliases

nat-add-comm : ∀ a b → a + b ≡ b + a
nat-add-comm = a+b=b+a


-- agad-modeの使い方
-- https://agda.readthedocs.io/en/latest/tools/emacs-mode.html
{-# OPTIONS --without-K --safe #-}
module Learn.Interactive where

-- ロード
-- タイプチェックする
-- C-c C-l
-- Ctrlを押しながら、cを押して次にlを押す
-- このとき、ソース内に"?"が存在すればそれをゴールにする
-- ゴールには番号が振られる

-- 型推論する
-- C-c C-d

-- 評価する
-- C-c C-n

-- 終了させる
-- C-c C-x C-q
-- Ctrlを押しながら、c、x、qと押す

-- 再スタートさせる
-- C-c C-x C-r

----------------------------------------------------------------------------
-- ゴールへの操作
-- ゴール内に値を書いてからゴールにカーソルを合わせ実行する。

-- 与える
-- C-c C-SPC
-- Ctrlを押しながら、cを押して次にスペースを押す
-- 型が合っていればゴールは消える

-- リファイン
-- C-c C-r
-- 何もない状態で行うと関数ならラムダ、レコード型ならコンストラクタを挿入する
-- ゴールに関数がある場合、関数の引数をゴールにする

-- ケーススプリット
-- C-c C-c
-- ゴール内に変数を書く、またはC-c C-cして出てきた入力枠に変数を入力すると
-- その変数でパターンマッチングを行う

-- ゴールの型を確認する
-- C-c C-t

-- 環境を確認する
-- C-c C-e

----------------------------------------------------------------------------
-- 自然数
data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

-- 等価性
infix 3 _≡_
data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

cong : ∀ {A B : Set} (f : A → B) {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

-- 足し算
-- 右辺に?と書いてC-c C-l(ロード)する
-- モジュールは無視で
module Step1 where
  _+_ : ℕ → ℕ → ℕ
  m + n = {!   !}

-- ゴールに"m"と入力する
module Step2 where
  _+_ : ℕ → ℕ → ℕ
  m + n = {! m  !}

--　ゴールにカーソルを合わせ C-c C-c (ケーススプリット)する
module Step3 where
  _+_ : ℕ → ℕ → ℕ
  zero + n = {!   !}
  suc m + n = {!   !}

-- インデントを整える
module Step4 where
  _+_ : ℕ → ℕ → ℕ
  zero  + n = {!   !}
  suc m + n = {!   !}

-- ゴール内に右辺値を書く
module Step5 where
  _+_ : ℕ → ℕ → ℕ
  zero  + n = {! zero  !}
  suc m + n = {!   !}

-- ゴールにカーソルを合わせ C-c C-SPC (Give)する
module Step6 where
  _+_ : ℕ → ℕ → ℕ
  zero  + n = zero
  suc m + n = {!   !}

-- もう一方のゴールも同様にする
-- このときmは再帰的な呼び出しをするときに小さくなっている
_+_ : ℕ → ℕ → ℕ
zero  + n = zero
suc m + n = suc (m + n)

-- +の結合性
-- 証明したい型を書く。右辺を?にしてゴールにする
module Assoc1 where
  +-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
  +-assoc m n o = {!   !}

-- このとき+の定義から+の左の変数で帰納するとよいとわかる
-- 単一の変数であるならばパターンマッチングできるのでmを選びゴールに書く
module Assoc2 where
  +-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
  +-assoc m n o = {! m  !}

-- C-c C-cする
-- ここで +-assoc zero n o の右辺のゴールでC-c C-tすると　zero ≡ zero とわかる
-- 同じ形ならreflが使えるのでreflをC-c C-SPCする
module Assoc3 where
  +-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
  +-assoc zero    n o = refl
  +-assoc (suc m) n o = {!   !}

-- 次に +-assoc (suc m) n o の右辺でC-c C-tすると
-- suc ((m + n) + o) ≡ suc (m + (n + o)) とわかる
-- 両辺に同じ関数（suc）が掛かっているのでcongが使える
-- congとゴール内に書く
module Assoc4 where
  +-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
  +-assoc zero    n o = refl
  +-assoc (suc m) n o = {!cong   !}

-- C-c C-rするとゴールが分かれる
-- 前はsucを与える
module Assoc5 where
  +-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
  +-assoc zero    n o = refl
  +-assoc (suc m) n o = cong suc {!   !}

-- 後ろは+-assoc m n oの型と同じなのでそれを与える
-- これで証明終了
module Assoc6 where
  +-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
  +-assoc zero    n o = refl
  +-assoc (suc m) n o = cong suc (+-assoc m n o)