-- ------------------------------------------------------------------------------------------------------
-- | ███████╗ ██████╗ ██╗     ██╗   ██╗██╗███╗   ██╗ ██████╗     ██████╗ ██╗███╗   ██╗ ██████╗ ███████╗ |
-- | ██╔════╝██╔═══██╗██║     ██║   ██║██║████╗  ██║██╔════╝     ██╔══██╗██║████╗  ██║██╔════╝ ██╔════╝ |
-- | ███████╗██║   ██║██║     ██║   ██║██║██╔██╗ ██║██║  ███╗    ██████╔╝██║██╔██╗ ██║██║  ███╗███████╗ |
-- | ╚════██║██║   ██║██║     ╚██╗ ██╔╝██║██║╚██╗██║██║   ██║    ██╔══██╗██║██║╚██╗██║██║   ██║╚════██║ |
-- | ███████║╚██████╔╝███████╗ ╚████╔╝ ██║██║ ╚████║╚██████╔╝    ██║  ██║██║██║ ╚████║╚██████╔╝███████║ |
-- | ╚══════╝ ╚═════╝ ╚══════╝  ╚═══╝  ╚═╝╚═╝  ╚═══╝ ╚═════╝     ╚═╝  ╚═╝╚═╝╚═╝  ╚═══╝ ╚═════╝ ╚══════╝ |
-- |                                                                                |
-- |                         ██╗███╗   ██╗     █████╗  ██████╗ ██████╗  █████╗                          |
-- |                         ██║████╗  ██║    ██╔══██╗██╔════╝ ██╔══██╗██╔══██╗                         |
-- |                         ██║██╔██╗ ██║    ███████║██║  ███╗██║  ██║███████║                         |
-- |                         ██║██║╚██╗██║    ██╔══██║██║   ██║██║  ██║██╔══██║                         |
-- |                         ██║██║ ╚████║    ██║  ██║╚██████╔╝██████╔╝██║  ██║                         |
-- |                         ╚═╝╚═╝  ╚═══╝    ╚═╝  ╚═╝ ╚═════╝ ╚═════╝ ╚═╝  ╚═╝                         |
-- ------------------------------------------------------------------------------------------------------
--
--                                        Donnacha Oisín Kidney
--                                            17 April 2019
--
-- Compiled with Agda version 2.6.1, and standard library commit 84d7962cfd90379a6d1d5ef2cdd9d3ae411ee603

-- This contains the worked-through source code for:
--
--     "Automatically And Efficiently Illustrating Polynomial Equalities in Agda"
--
--     We present a new library which automates the construction of equivalence
--     proofs between polynomials over commutative rings and semirings in the
--     programming language Agda. It is asymptotically faster than Agda's existing
--     solver. We use Agda's reflection machinery to provide a simple interface to
--     the solver, and demonstrate an interesting use of the constructed relations:
--     step-by-step solutions.
--
-- Which is (at time of writing) a work-in-progress.
--
-- This code is available on github:
--     https://github.com/oisdk/agda-ring-solver
--
-- As is the paper:
--     https://github.com/oisdk/agda-ring-solver-report

module README where

--------------------------------------------------------------------------------
-- There are 3 main contributions in this library:                            --
--                                                                            --
--   * A solver for polynomials over "almost commutative rings".              --
--         Agda already has one these in the standard library, but this one   --
--         is much more efficient. "Almost commutative rings" encapsulates a  --
--         bunch of things, including ℕ.                                      --
--                                                                            --
--   * A reflection-based interface.                                          --
--         Not many people used the old solver, mainly (I think) because the  --
--         interface was difficult and irritating. This library provides a    --
--         super-simple interface using reflection.                           --
--                                                                            --
--   * An implementation of "step-by-step solutions".                         --
--         I don't know a huge amount about computer algebra systems, but I   --
--         have used Wolfram Alpha countless times (especially when I was in  --
--         school) to help with basic maths. I was able to get this solver to --
--         produce step-by-step solutions, and learned something about the    --
--         theory behind them along the way.                                  --
--------------------------------------------------------------------------------
--
-- ██████╗ ███████╗███╗   ██╗ ██████╗██╗  ██╗███╗   ███╗ █████╗ ██████╗ ██╗  ██╗███████╗
-- ██╔══██╗██╔════╝████╗  ██║██╔════╝██║  ██║████╗ ████║██╔══██╗██╔══██╗██║ ██╔╝██╔════╝
-- ██████╔╝█████╗  ██╔██╗ ██║██║     ███████║██╔████╔██║███████║██████╔╝█████╔╝ ███████╗ ███████╗
-- ██╔══██╗██╔══╝  ██║╚██╗██║██║     ██╔══██║██║╚██╔╝██║██╔══██║██╔══██╗██╔═██╗ ╚════██║ ╚════██║
-- ██████╔╝███████╗██║ ╚████║╚██████╗██║  ██║██║ ╚═╝ ██║██║  ██║██║  ██║██║  ██╗███████║      ██║
-- ╚═════╝ ╚══════╝╚═╝  ╚═══╝ ╚═════╝╚═╝  ╚═╝╚═╝     ╚═╝╚═╝  ╚═╝╚═╝  ╚═╝╚═╝  ╚═╝╚══════╝      ██║
--                                                                                ██║
-- ███████╗██╗  ██╗ █████╗ ███╗   ███╗██████╗ ██╗     ███████╗███████╗                        ██║
-- ██╔════╝╚██╗██╔╝██╔══██╗████╗ ████║██╔══██╗██║     ██╔════╝██╔════╝                        ██║
-- █████╗   ╚███╔╝ ███████║██╔████╔██║██████╔╝██║     █████╗  ███████╗ ████████████████████╗  ██║
-- ██╔══╝   ██╔██╗ ██╔══██║██║╚██╔╝██║██╔═══╝ ██║     ██╔══╝  ╚════██║ ╚═════════════════██║  ██║
-- ███████╗██╔╝ ██╗██║  ██║██║ ╚═╝ ██║██║     ███████╗███████╗███████║                   ██║  ██║
-- ╚══════╝╚═╝  ╚═╝╚═╝  ╚═╝╚═╝     ╚═╝╚═╝     ╚══════╝╚══════╝╚══════╝                   ██║  ██║
--                                                                                ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
-- You can ignore this bit! We're just overloading the literals Agda uses for --         ██║  ██║
-- numbers This bit isn't necessary if you're just using Nats, or if you      --         ██║  ██║
-- construct your type directly. We only really do it here so that we can use --         ██║  ██║
-- different numeric types in the same file.                                  --         ██║  ██║
                                                                              --         ██║  ██║
open import Agda.Builtin.FromNat                                              --         ██║  ██║
open import Data.Nat using (ℕ; suc)                                           --         ██║  ██║
open import Data.Integer using (ℤ)                                            --         ██║  ██║
                                                                              --         ██║  ██║
instance                                                                      --         ██║  ██║
  numberNat : Number ℕ                                                        --         ██║  ██║
  numberNat = Data.Nat.Literals.number                                        --         ██║  ██║
    where import Data.Nat.Literals                                            --         ██║  ██║
                                                                              --         ██║  ██║
instance                                                                      --         ██║  ██║
  numberInt : Number ℤ                                                        --         ██║  ██║
  numberInt = Data.Integer.Literals.number                                    --         ██║  ██║
    where import Data.Integer.Literals                                        --         ██║  ██║
                                                                              --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
-- Imports!                                                                   --         ██║  ██║
                                                                              --         ██║  ██║
open import Polynomial.Simple.AlmostCommutativeRing                           --         ██║  ██║
open import Polynomial.Simple.AlmostCommutativeRing.Instances                 --         ██║  ██║
open import Polynomial.Simple.Reflection                                      --         ██║  ██║
open import Data.List as List using (List; _∷_; [])                           --         ██║  ██║
open import Function                                                          --         ██║  ██║
open import Relation.Binary.PropositionalEquality as ≡ using (subst; _≡_)     --         ██║  ██║
open import Data.Bool as Bool using (Bool; true; false; if_then_else_)        --         ██║  ██║
open import Data.Unit using (⊤; tt)                                           --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
--                                                                            --         ██║  ██║
--                           8888888888',8888'                                --         ██║  ██║
--                                  ,8',8888'                                 --         ██║  ██║
--                                 ,8',8888'                                  --         ██║  ██║
--                                ,8',8888'                                   --         ██║  ██║
--                               ,8',8888'                                    --         ██║  ██║
--                              ,8',8888'                                     --         ██║  ██║
--                             ,8',8888'                                      --         ██║  ██║
--                            ,8',8888'                                       --         ██║  ██║
--                           ,8',8888'                                        --         ██║  ██║
--                          ,8',8888888888888                                 --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
--                                                                            --         ██║  ██║
module IntExamples where                                                      --         ██║  ██║
  open AlmostCommutativeRing Int.ring                                         --         ██║  ██║
  -- Everything is automatic: you just ask Agda to solve it and it does!      --     ██╗ ██║  ██║
  lemma₁ : ∀ x y → x + y * 1 + 3 ≈ 3 + 1 + y + x + - 1                        --   ████║ ██║  ██║
  lemma₁ = solve Int.ring                                                     -- ██████████║  ██║
                                                                              --   ████╔═██║  ██║
  lemma₂ : ∀ x y → (x + y) ^ 2 ≈ x ^ 2 + 2 * x * y + y ^ 2                    --     ██║ ██║  ██║
  lemma₂ = solve Int.ring                                                     --     ╚═╝ ██║  ██║
                                                                              --         ██║  ██║
  open import Relation.Binary.Reasoning.Inference setoid                      --         ██║  ██║
                                                                              --         ██║  ██║
  -- It can interact with manual proofs as well.                              --         ██║  ██║
  lemma₃ : ∀ x y → x + y * 1 + 3 ≈ 2 + 1 + y + x                              --         ██║  ██║
  lemma₃ x y = begin                                                          --         ██║  ██║
    x + y * 1 + 3 ≈⟨ +-comm x (y * 1) ⟨ +-cong ⟩ refl ⟩                       --         ██║  ██║
    y * 1 + x + 3 ≈⟨ solveOver (x ∷ y ∷ []) Int.ring ⟩                        --         ██║  ██║
    3 + y + x     ≡⟨⟩                                                         --         ██║  ██║
    2 + 1 + y + x ∎                                                           --         ██║  ██║
                                                                              --         ██║  ██║
  open Int.Reflection                                                         --         ██║  ██║
                                                                              --         ██║  ██║
  -- There's a shorthand included for Int and Nat.                            --         ██║  ██║
  lemma₄ : ∀ x y → x + y * 1 + 3 ≈ 2 + 1 + y + x                              --         ██║  ██║
  lemma₄ x y = begin                                                          --         ██║  ██║
    x + y * 1 + 3 ≈⟨ +-comm x (y * 1) ⟨ +-cong ⟩ refl ⟩                       --         ██║  ██║
    y * 1 + x + 3 ≈⟨ ∀⟨ x ∷ y ∷ [] ⟩ ⟩                                        --         ██║  ██║
    3 + y + x     ≡⟨⟩                                                         --         ██║  ██║
    2 + 1 + y + x ∎                                                           --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
--                                                                            --         ██║  ██║
--                          b.             8                                  --         ██║  ██║
--                          888o.          8                                  --         ██║  ██║
--                          Y88888o.       8                                  --         ██║  ██║
--                          .`Y888888o.    8                                  --         ██║  ██║
--                          8o. `Y888888o. 8                                  --         ██║  ██║
--                          8`Y8o. `Y88888o8                                  --         ██║  ██║
--                          8   `Y8o. `Y8888                                  --         ██║  ██║
--                          8      `Y8o. `Y8                                  --         ██║  ██║
--                          8         `Y8o.`                                  --         ██║  ██║
--                          8            `Yo                                  --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
--                                                                            --         ██║  ██║
module NatExamples where                                                      --         ██║  ██║
  open AlmostCommutativeRing Nat.ring                                         --     ██╗ ██║  ██║
  -- The solver is flexible enough to work with Nats (even though it asks     --   ████║ ██║  ██║
  -- for rings!)                                                              -- ██████████║  ██║
  lemma₁ : ∀ x y → x + y * 1 + 3 ≈ 2 + 1 + y + x                              --   ████╔═██║  ██║
  lemma₁ = solve Nat.ring                                                     --     ██║ ██║  ██║
                                                                              --     ╚═╝ ██║  ██║
  lemma₂ : ∀ x y → x + y * 1 + 3 ≈ 2 + suc y + x                              --         ██║  ██║
  lemma₂ = solve Nat.ring                                                     --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
--                                                                            --         ██║  ██║
--          #####  #     # #######  #####  #    # ### #     #  #####          --         ██║  ██║
--         #     # #     # #       #     # #   #   #  ##    # #     #         --         ██║  ██║
--         #       #     # #       #       #  #    #  # #   # #               --         ██║  ██║
--         #       ####### #####   #       ###     #  #  #  # #  ####         --         ██║  ██║
--         #       #     # #       #       #  #    #  #   # # #     #         --         ██║  ██║
--         #     # #     # #       #     # #   #   #  #    ## #     #         --         ██║  ██║
--          #####  #     # #######  #####  #    # ### #     #  #####          --         ██║  ██║
--                                                                            --         ██║  ██║
--   ### #     # #     #    #    ######  ###    #    #     # #######  #####   --         ██║  ██║
--    #  ##    # #     #   # #   #     #  #    # #   ##    #    #    #     #  --         ██║  ██║
--    #  # #   # #     #  #   #  #     #  #   #   #  # #   #    #    #        --         ██║  ██║
--    #  #  #  # #     # #     # ######   #  #     # #  #  #    #     #####   --         ██║  ██║
--    #  #   # #  #   #  ####### #   #    #  ####### #   # #    #          #  --         ██║  ██║
--    #  #    ##   # #   #     # #    #   #  #     # #    ##    #    #     #  --         ██║  ██║
--   ### #     #    #    #     # #     # ### #     # #     #    #     #####   --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
-- The solver makes it easy to prove invariants, without having to rewrite    --         ██║  ██║
-- proof code every time something changes in the data structure.             --         ██║  ██║
--                                                                            --         ██║  ██║
  module _ {a} {A : Set a} (_≤_ : A → A → Bool) where                         --         ██║  ██║
   -- A Skew Heap, indexed by its size.                                       --         ██║  ██║
   data Tree : ℕ → Set a where                                                --         ██║  ██║
     leaf : Tree 0                                                            --         ██║  ██║
     node : ∀ {n m} → A → Tree n → Tree m → Tree (n + m + 1)                  --         ██║  ██║
                                                                              --         ██║  ██║
   -- A substitution operator, to clean things up.                            --         ██║  ██║
   _⇒_ : ∀ {n} → Tree n → ∀ {m} → n ≈ m → Tree m                              --         ██║  ██║
   x ⇒ n≈m  = subst Tree n≈m x                                                --         ██║  ██║
                                                                              --         ██║  ██║
   open Nat.Reflection                                                        --         ██║  ██║
                                                                              --         ██║  ██║
-- _∪_ : ∀ {n m} → Tree n → Tree m → Tree (n + m)                             --         ██║  ██║
-- leaf ∪ ys = ys                                                             --         ██║  ██║
-- node {a} {b} x xl xr ∪ leaf =                                              --         ██║  ██║
--   node x xl xr ⇒ ∀⟨ a ∷ b ∷ [] ⟩                                           --     ██╗ ██║  ██║
-- node {a} {b} x xl xr ∪ node {c} {d} y yl yr = if x ≤ y                     --   ████║ ██║  ██║
--          then node x (node y yl yr ∪ xr) xl                                -- ██████████║  ██║
--                 ⇒ ∀⟨ a ∷ b ∷ c ∷ d ∷ [] ⟩                                  --   ████╔═██║  ██║
--          else (node y (node x xl xr ∪ yr) yl                               --     ██║ ██║  ██║
--                 ⇒ ∀⟨ a ∷ b ∷ c ∷ d ∷ [] ⟩)                                 --     ╚═╝ ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
--                                                                            --         ██║  ██║
--             8888888 8888888888 8 8888        8 8 8888888888                --         ██║  ██║
--                   8 8888       8 8888        8 8 8888                      --         ██║  ██║
--                   8 8888       8 8888        8 8 8888                      --         ██║  ██║
--                   8 8888       8 8888        8 8 8888                      --         ██║  ██║
--                   8 8888       8 8888        8 8 888888888888              --         ██║  ██║
--                   8 8888       8 8888        8 8 8888                      --         ██║  ██║
--                   8 8888       8 8888888888888 8 8888                      --         ██║  ██║
--                   8 8888       8 8888        8 8 8888                      --         ██║  ██║
--                   8 8888       8 8888        8 8 8888                      --         ██║  ██║
--                   8 8888       8 8888        8 8 888888888888              --         ██║  ██║
--                                                                            --         ██║  ██║
--                 ,o888888o.     8 8888         8 888888888o.                --         ██║  ██║
--              . 8888     `88.   8 8888         8 8888    `^888.             --         ██║  ██║
--             ,8 8888       `8b  8 8888         8 8888        `88.           --         ██║  ██║
--             88 8888        `8b 8 8888         8 8888         `88           --         ██║  ██║
--             88 8888         88 8 8888         8 8888          88           --         ██║  ██║
--             88 8888         88 8 8888         8 8888          88           --         ██║  ██║
--             88 8888        ,8P 8 8888         8 8888         ,88           --         ██║  ██║
--             `8 8888       ,8P  8 8888         8 8888        ,88'           --         ██║  ██║
--              ` 8888     ,88'   8 8888         8 8888    ,o88P'             --         ██║  ██║
--                 `8888888P'     8 888888888888 8 888888888P'                --         ██║  ██║
--                                                                            --         ██║  ██║
--             `8.`888b                 ,8' .8.   `8.`8888.      ,8'          --         ██║  ██║
--              `8.`888b               ,8' .888.   `8.`8888.    ,8'           --         ██║  ██║
--               `8.`888b             ,8' :88888.   `8.`8888.  ,8'            --         ██║  ██║
--                `8.`888b     .b    ,8' . `88888.   `8.`8888.,8'             --         ██║  ██║
--                 `8.`888b    88b  ,8' .8. `88888.   `8.`88888'              --         ██║  ██║
--                  `8.`888b .`888b,8' .8`8. `88888.   `8. 8888               --         ██║  ██║
--                   `8.`888b8.`8888' .8' `8. `88888.   `8 8888               --         ██║  ██║
--                    `8.`888`8.`88' .8'   `8. `88888.   8 8888               --         ██║  ██║
--                     `8.`8' `8,`' .888888888. `88888.  8 8888               --         ██║  ██║
--                      `8.`   `8' .8'       `8. `88888. 8 8888               --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
-- Previously, you had to construct the expression you wanted to solve twice: --         ██║  ██║
-- once in the type signature, and again using the special solver syntax.     --         ██║  ██║
--                                                                            --         ██║  ██║
-- This is difficult to learn, and error-prone: if I change an x + y          --         ██║  ██║
-- somewhere to a y + x, I *also* have to change the proofs now! The          --         ██║  ██║
-- reflection-based solver will automatically construct the new proof.        --         ██║  ██║
--                                                                            --         ██║  ██║
module OldSolver where                                                        --         ██║  ██║
  open import Data.Nat                                                        --         ██║  ██║
  open import Data.Nat.Solver using (module +-*-Solver)                       --         ██║  ██║
  open +-*-Solver                                                             --         ██║  ██║
                                                                              --     ██╗ ██║  ██║
--lemma : ∀ x y → x + y * 1 + 3 ≡ 2 + 1 + y + x                               --   ████║ ██║  ██║
--lemma = +-*-Solver.solve 2                                                  -- ██████████║  ██║
--  (λ x y → x :+ y :* con 1 :+ con 3 := con 2 :+ con 1 :+ y :+ x) ≡.refl     --   ████╔═██║  ██║
--                                                                            --     ██║ ██║  ██║
--------------------------------------------------------------------------------     ╚═╝ ██║  ██║
--                                                                            --         ██║  ██║
--          d888888o.   8888888 8888888888 8 8888888888   8 888888888o        --         ██║  ██║
--        .`8888:' `88.       8 8888       8 8888         8 8888    `88.      --         ██║  ██║
--        8.`8888.   Y8       8 8888       8 8888         8 8888     `88      --         ██║  ██║
--        `8.`8888.           8 8888       8 8888         8 8888     ,88      --         ██║  ██║
--         `8.`8888.          8 8888       8 888888888888 8 8888.   ,88'      --         ██║  ██║
--          `8.`8888.         8 8888       8 8888         8 888888888P'       --         ██║  ██║
--           `8.`8888.        8 8888       8 8888         8 8888              --         ██║  ██║
--       8b   `8.`8888.       8 8888       8 8888         8 8888              --         ██║  ██║
--       `8b.  ;8.`8888       8 8888       8 8888         8 8888              --         ██║  ██║
--        `Y8888P ,88P'       8 8888       8 888888888888 8 8888              --         ██║  ██║
--                                                                            --         ██║  ██║
--                      8 888888888o   `8.`8888.      ,8'                     --         ██║  ██║
--                      8 8888    `88.  `8.`8888.    ,8'                      --         ██║  ██║
--                      8 8888     `88   `8.`8888.  ,8'                       --         ██║  ██║
--                      8 8888     ,88    `8.`8888.,8'                        --         ██║  ██║
--                      8 8888.   ,88'     `8.`88888'                         --         ██║  ██║
--                      8 8888888888        `8. 8888                          --         ██║  ██║
--                      8 8888    `88.       `8 8888                          --         ██║  ██║
--                      8 8888      88        8 8888                          --         ██║  ██║
--                      8 8888    ,88'        8 8888                          --         ██║  ██║
--                      8 888888888P          8 8888                          --         ██║  ██║
--                                                                            --         ██║  ██║
--          d888888o.   8888888 8888888888 8 8888888888   8 888888888o        --         ██║  ██║
--        .`8888:' `88.       8 8888       8 8888         8 8888    `88.      --         ██║  ██║
--        8.`8888.   Y8       8 8888       8 8888         8 8888     `88      --         ██║  ██║
--        `8.`8888.           8 8888       8 8888         8 8888     ,88      --         ██║  ██║
--         `8.`8888.          8 8888       8 888888888888 8 8888.   ,88'      --         ██║  ██║
--          `8.`8888.         8 8888       8 8888         8 888888888P'       --         ██║  ██║
--           `8.`8888.        8 8888       8 8888         8 8888              --         ██║  ██║
--       8b   `8.`8888.       8 8888       8 8888         8 8888              --         ██║  ██║
--       `8b.  ;8.`8888       8 8888       8 8888         8 8888              --         ██║  ██║
--        `Y8888P ,88P'       8 8888       8 888888888888 8 8888              --         ██║  ██║
--                                                                            --         ██║  ██║
--------------------------------------------------------------------------------         ██║  ██║
-- Don't understand why something works? Wanna get it explained to you? Now   --         ██║  ██║
-- you can! The solver can generate step-by-step, human-readable solutions    --         ██║  ██║
-- for learning purposes.                                                     --         ██║  ██║
--                                                                            --         ██║  ██║
module TracedExamples where                                                   --         ██║  ██║
  import Data.Nat.Show                                                        --         ██║  ██║
  open import EqBool                                                          --         ██║  ██║
  open import Relation.Traced Nat.ring  Data.Nat.Show.show public             --         ██║  ██║
  open AlmostCommutativeRing tracedRing                                       --         ██║  ██║
                                                                              --         ██║  ██║
  lemma : ∀ x y → x + y * 1 + 3 ≈ 2 + 1 + y + x                               --         ██║  ██║
  lemma = solve tracedRing                                                    --         ██║  ██║
                                                                              --      ██╗██║  ██║
  explained                                                                   --    ████║██║  ██║
    : showProof (lemma "x" "y") ≡ "x + y + 3"                                 --  █████████║  ██║
                                ∷ "    ={ +-comm(x, y + 3) }"                 --    ████╔══╝  ██║
                                ∷ "y + 3 + x"                                 --      ██║     ██║
                                ∷ "    ={ +-comm(y, 3) }"                     --      ╚═╝     ██║
                                ∷ "3 + y + x"                                 --              ██║
                                ∷ []                                          --              ██║
  explained = ≡.refl                                                          --              ██║
--------------------------------------------------------------------------------              ██║
--                                                                            --              ██║
-- The new solver uses a sparse representation, which is much faster than the --              ██║
-- dense one the old solver used. The following graph shows the time (in      --              ██║
-- seconds) to prove that:                                                    --              ██║
--                                                                            --              ██║
--     (1 + x₁¹ + x₂² + x₃³ + x₄⁴ + x₅⁵)ᵈ                                     --              ██║
--                                                                            --              ██║
-- is equal to its expanded form. (to run the benchmarks yourself, run the    --              ██║
-- run_benchmarks.py file. You'll need python 3 and sympy.)                   --              ██║
--                                                                            --              ██║
-- 540 |  * = old                                                       *     --              ██║
-- 525 |  + = new                                                       *     --              ██║
-- 510 |                                                                *     --              ██║
-- 495 |                                                                *     --              ██║
-- 480 |                                                                *     --              ██║
-- 465 |                                                               *      --              ██║
-- 450 |                                                               *      --              ██║
-- 435 |                                                               *      --              ██║
-- 420 |                                                              *       --              ██║
-- 405 |                                                              *       --              ██║
-- 390 |                                                              *       --              ██║
-- 375 |                                                             *        --              ██║
-- 360 |                                                             *        --              ██║
-- 345 |                                                             *        --              ██║
-- 330 |                                                            *         --              ██║
-- 315 |                                                            *         --              ██║
-- 300 |                                                            *         --              ██║
-- 285 |                                                           *          --              ██║
-- 270 |                                                           *          --              ██║
-- 255 |                                                           *          --              ██║
-- 240 |                                                          *           --           ██╗██║
-- 225 |                                                          *           --         ████║██║
-- 210 |                                                          *           --       █████████║
-- 195 |                                                         *            --         ████╔══╝
-- 180 |                                                         *            --           ██║
-- 165 |                                                         *            --           ╚═╝
-- 150 |                                                        *             --
-- 135 |                                                        *             --
-- 120 |                                                        *             --
-- 105 |                                                       *              --
--  90 |                                                      *               --
--  75 |                                                     *                --
--  60 |                                                   **                 --
--  45 |                                                 **                   --
--  30 |                                               **           +++++     --
--  15 |                                          *****    +++++++++          --
--   0 | *****************************************+++++++++                   --
--     ------------------------------------------------------------------     --
--   d = 1        2        3        4        5        6        7        8     --
--------------------------------------------------------------------------------
--
-- * How does it work? Why is it fast?
--       The solver works by converting expressions to "Horner Normal Form".
--       This representation is special: x + y is represented in the same way
--       as y + x. This is what lets us check that two expressions are equal.
--       The implementation here is *sparse*, also, which is why it's faster
--       than the old implementation.
--
--       Want to learn more? Then this is the place for you:
import Polynomial.NormalForm
--
-- * Prove it!
--       The type of proofs we need are *homomorphisms*. They basically mean
--       that the operations on the normal form correspond to the operations
--       on expressions. Also, we don't use propositional equality: we use
--       any equivalence relation the user supplies.
--
--       Don't believe me? Check it out:
import Polynomial.Homomorphism
--
-- * How do I use it?
--       Copy the examples above! For the full solver, check out:
import Polynomial.Solver
--
-- * Wait! Don't!
--       The "full" solver lets you use different types for the coefficient
--       and carrier. You probably don't want that, unless you need the extra
--       efficiency. You'll want the *simple* solver:
import Polynomial.Simple.Solver
--
-- * Is that all?
--       No! As it happens, even the simple solver is complicated to use.
--       You'll *actually* want to use the reflection-based interface:
import Polynomial.Simple.Reflection
--
-- * And what about the step-by-step stuff?
--       That all uses the same underlying solver as the other stuff, with a
--       special *relation*. You can check that out here:
import Relation.Traced


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

module CauchyProofsS where

-- Proofs about permutations defined in module Cauchy (multiplicative2)

open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; subst; subst₂; cong; cong₂; setoid;
        proof-irrelevance; module ≡-Reasoning)
open import Relation.Binary.PropositionalEquality.TrustMe
  using (trustMe)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Data.Nat.Properties
  using (m≤m+n; n≤m+n; n≤1+n; cancel-+-left; cancel-*-right; strictTotalOrder;
         cancel-*-right-≤; ≰⇒>; ¬i+1+j≤i; 1+n≰n; ≤⇒pred≤)
open import Data.Nat.Properties.Simple
  using (+-right-identity; +-suc; +-assoc; +-comm;
        *-assoc; *-comm; *-right-zero; distribʳ-*-+; +-*-suc)
open import Data.Nat.DivMod using (DivMod; result; _divMod_; _div_; _mod_)
open import Relation.Binary
  using (Rel; Decidable; Setoid; StrictTotalOrder; IsStrictTotalOrder;
         tri<; tri≈; tri>)
open import Relation.Binary.Core using (Transitive; _⇒_)

open import Data.String using (String)
  renaming (_++_ to _++S_)
open import Data.Nat.Show using (show)
open import Data.Bool using (Bool; false; true; _∨_)
open import Data.Nat using (ℕ; suc; _+_; _∸_; _*_; _<_; _≮_; _≤_; _≰_;
  _≥_; z≤n; s≤s; _≟_; _≤?_; ≤-pred; module ≤-Reasoning)
open import Data.Fin
  using (Fin; zero; suc; toℕ; fromℕ; fromℕ≤; _ℕ-_; _≺_; reduce≥;
         raise; inject+; inject₁; inject≤; _≻toℕ_; #_)
  renaming (_+_ to _F+_)
open import Data.Fin.Properties
  using (bounded; inject+-lemma; to-from; toℕ-injective; inject≤-lemma;
         toℕ-fromℕ≤; fromℕ≤-toℕ)
open import Data.Vec.Properties
  using (lookup∘tabulate; tabulate∘lookup; lookup-allFin; tabulate-∘;
         tabulate-allFin; allFin-map; lookup-++-inject+; lookup-++-≥;
         module UsingVectorEquality)
open import Data.Product using (Σ; swap)

open import Data.List
  using (List; []; _∷_; _∷ʳ_; foldl; replicate; reverse; downFrom;
         concatMap; gfilter; initLast; InitLast; _∷ʳ'_)
  renaming (_++_ to _++L_; map to mapL; concat to concatL; zip to zipL)
open import Data.List.NonEmpty
  using (List⁺; [_]; _∷⁺_; head; last; _⁺++_)
  renaming (toList to nonEmptyListtoList; _∷ʳ_ to _n∷ʳ_; tail to ntail)
open import Data.List.Any using (Any; here; there; any; module Membership)
open import Data.Maybe using (Maybe; nothing; just; maybe′)
open import Data.Vec
  using (Vec; tabulate; []; _∷_; tail; lookup; zip; zipWith; splitAt;
         _[_]≔_; allFin; toList)
  renaming (_++_ to _++V_; map to mapV; concat to concatV)
open import Function using (id; _∘_; _$_; _∋_)

open import Data.Empty   using (⊥; ⊥-elim)
open import Data.Unit    using (⊤; tt)
open import Data.Sum     using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂)

open import DivModUtils using (mod-lemma)
open import Proofs
open import Cauchy
open import Perm
open import CauchyProofs
open import CauchyProofsT

------------------------------------------------------------------------------
-- Main lemma swap⋆idemp

subst-allFin : ∀ {m n} → (eq : m ≡ n) → subst Cauchy eq (allFin m) ≡ allFin n
subst-allFin refl = refl

concat-simplify : {A : Set} → (m n : ℕ) → (f : Fin (suc m) → Vec A (suc n)) →
  concatV (mapV f (allFin (suc m))) ≡
  f zero ++V concatV (mapV (f ∘ suc) (allFin m))
concat-simplify m n f =
  begin (concatV (mapV f (allFin (suc m)))
        ≡⟨ cong
            (λ x → concatV (mapV f x))
            (allFin-map m) ⟩
         concatV (mapV f (zero ∷ mapV suc (allFin m)))
        ≡⟨ refl ⟩
         concatV (f zero ∷ mapV f (mapV suc (allFin m)))
        ≡⟨ cong (λ x → concatV (f zero ∷ x)) (sym (map-∘ f suc (allFin m))) ⟩
          f zero ++V concatV (mapV (λ a → f (suc a)) (allFin m)) ∎)
  where open ≡-Reasoning

concat-simplify-inject : {A : Set} → (m n : ℕ) (i : Fin (suc (suc n))) →
  (f : Fin (suc (suc m)) → Vec A (suc (suc n))) →
  lookup
    (inject+ (suc m * suc (suc n)) i)
    (concatV (mapV f (allFin (suc (suc m))))) ≡
  lookup i (f zero)
concat-simplify-inject m n i f =
  begin (lookup
           (inject+ (suc m * suc (suc n)) i)
           (concatV (mapV f (allFin (suc (suc m)))))
        ≡⟨ cong
             (lookup (inject+ (suc m * suc (suc n)) i))
             (concat-simplify (suc m) (suc n) f) ⟩
         lookup
           (inject+ (suc m * suc (suc n)) i)
           (f zero ++V concatV (mapV (λ a → f (suc a)) (allFin (suc m))))
        ≡⟨ lookup-++-inject+
             (f zero) (concatV (mapV (λ a → f (suc a)) (allFin (suc m)))) i ⟩
          lookup i (f zero) ∎)
  where open ≡-Reasoning

concat-simplify-raise : {A : Set} → (m n : ℕ) (i : Fin (suc m * suc (suc n))) →
  (f : Fin (suc (suc m)) → Vec A (suc (suc n))) →
  lookup
    (raise (suc (suc n)) i)
    (concatV (mapV f (allFin (suc (suc m))))) ≡
  lookup i (concatV (mapV (λ a → f (suc a)) (allFin (suc m))))
concat-simplify-raise m n i f =
  begin (lookup
           (raise (suc (suc n)) i)
           (concatV (mapV f (allFin (suc (suc m)))))
        ≡⟨ cong
            (lookup (raise (suc (suc n)) i))
            (concat-simplify (suc m) (suc n) f) ⟩
         lookup
           (raise (suc (suc n)) i)
           (f zero ++V concatV (mapV (λ a → f (suc a)) (allFin (suc m))))
         ≡⟨ lookup-++-raise
             (f zero) (concatV (mapV (λ a → f (suc a)) (allFin (suc m)))) i ⟩
         lookup i (concatV (mapV (λ a → f (suc a)) (allFin (suc m)))) ∎)
  where open ≡-Reasoning

lookup-subst-1 : ∀ {m m'}
  (i : Fin m') (xs : Vec (Fin m) m) (eq : m ≡ m') (eq' : m' ≡ m)
  (irr : sym eq ≡ eq') →
  lookup i (subst (λ s → Vec (Fin s) s) eq xs) ≡
  subst Fin eq (lookup (subst Fin eq' i) xs)
lookup-subst-1 i xs refl .refl refl = refl

subst-inject-mod : ∀ {n m m'} → (eq : suc (suc m) ≡ suc (suc m')) →
  subst Fin eq (inject≤ (n mod (suc m)) (i≤si (suc m))) ≡
  inject≤ (n mod (suc m')) (i≤si (suc m'))
subst-inject-mod refl = refl

cmp = IsStrictTotalOrder.compare
        (StrictTotalOrder.isStrictTotalOrder strictTotalOrder)

max-b-d : (m n : ℕ) → (b : Fin (suc (suc m))) (d : Fin (suc (suc n))) →
  (p= : suc (toℕ b * suc (suc n) + toℕ d) ≡ suc (suc m) * suc (suc n)) →
  (toℕ b ≡ suc m × toℕ d ≡ suc n)
max-b-d m n b d p= with cmp (toℕ b) (suc m) | cmp (toℕ d) (suc n)
max-b-d m n b d p= | tri< a ¬b ¬c | tri< a₁ ¬b₁ ¬c₁ = ⊥-elim (1+n≰n contra)
  where contra = begin (1 + suc (toℕ b * suc (suc n) + toℕ d)
                        ≡⟨ cong suc (sym (+-suc (toℕ b * suc (suc n)) (toℕ d))) ⟩
                        1 + (toℕ b * suc (suc n) + suc (toℕ d))
                        ≡⟨ sym (+-suc (toℕ b * suc (suc n)) (suc (toℕ d))) ⟩
                        toℕ b * suc (suc n) + suc (suc (toℕ d))
                        ≤⟨ cong+l≤ (s≤s a₁) (toℕ b * suc (suc n)) ⟩
                        toℕ b * suc (suc n) + suc (suc n)
                        ≡⟨ +-comm (toℕ b * suc (suc n)) (suc (suc n)) ⟩
                        suc (toℕ b) * suc (suc n)
                        ≤⟨ cong*r≤ (≰⇒> ¬c) (suc (suc n)) ⟩
                        suc (suc m) * suc (suc n)
                        ≡⟨ sym p= ⟩
                        suc (toℕ b * suc (suc n) + toℕ d) ∎)
                 where open ≤-Reasoning
max-b-d m n b d p= | tri< a ¬b= ¬c | tri≈ ¬a d= ¬c₁ =
  ⊥-elim (¬b= (cancel-+-left 1
    (cancel-*-right (suc (toℕ b)) (suc (suc m)) {suc n} contra)))
  where
    contra : suc (toℕ b) * suc (suc n) ≡ suc (suc m) * suc (suc n)
    contra = begin (suc (toℕ b) * suc (suc n)
                   ≡⟨  refl ⟩
                   suc (suc n) + toℕ b * suc (suc n)
                   ≡⟨  +-comm (suc (suc n)) (toℕ b * suc (suc n)) ⟩
                   toℕ b * suc (suc n) + suc (suc n)
                   ≡⟨  +-suc (toℕ b * suc (suc n)) (suc n) ⟩
                   suc (toℕ b * suc (suc n) + suc n)
                   ≡⟨  cong (λ x → suc (toℕ b * suc (suc n) + x)) (sym d=) ⟩
                   suc (toℕ b * suc (suc n) + toℕ d)
                   ≡⟨  p= ⟩
                   suc (suc m) * suc (suc n) ∎)
             where open ≡-Reasoning
max-b-d m n b d p= | tri< a ¬b ¬c | tri> ¬a ¬b₁ c =
  ⊥-elim (1+n≰n (trans≤ (bounded d) c))
max-b-d m n b d p= | tri≈ ¬a b= ¬c | tri< a ¬d= ¬c₁ =
  ⊥-elim (¬d= (cancel-+-left 1
    (cancel-+-left (suc m * suc (suc n)) contra)))
  where
     contra : suc m * suc (suc n) + suc (toℕ d) ≡ suc m * suc (suc n) + suc (suc n)
     contra = begin (suc m * suc (suc n) + suc (toℕ d)
                    ≡⟨ cong (λ x → x * suc (suc n) + suc (toℕ d)) (sym b=) ⟩
                    toℕ b * suc (suc n) + suc (toℕ d)
                    ≡⟨ +-suc (toℕ b * suc (suc n)) (toℕ d) ⟩
                    suc (toℕ b * suc (suc n) + toℕ d)
                    ≡⟨ p= ⟩
                    suc (suc m) * suc (suc n)
                    ≡⟨ +-comm (suc (suc n)) (suc m * suc (suc n)) ⟩
                    suc m * suc (suc n) + suc (suc n) ∎)
              where open ≡-Reasoning
max-b-d m n b d p= | tri≈ ¬a b₁ ¬c | tri≈ ¬a₁ b₂ ¬c₁ = (b₁ , b₂)
max-b-d m n b d p= | tri≈ ¬a b₁ ¬c | tri> ¬a₁ ¬b c =
  ⊥-elim (1+n≰n (trans≤ (bounded d) c))
max-b-d m n b d p= | tri> ¬a ¬b c | tri< a ¬b₁ ¬c =
  ⊥-elim (1+n≰n (trans≤ (bounded b) c))
max-b-d m n b d p= | tri> ¬a ¬b c | tri≈ ¬a₁ b₁ ¬c =
  ⊥-elim (1+n≰n (trans≤ (bounded b) c))
max-b-d m n b d p= | tri> ¬a ¬b c | tri> ¬a₁ ¬b₁ c₁ =
  ⊥-elim (1+n≰n (trans≤ (bounded d) c₁))

subst-fin : (a b : ℕ) → (eq : suc a ≡ suc b) → subst Fin eq (fromℕ a) ≡ fromℕ b
subst-fin a .a refl = refl

lookup-fromℕ-allFin : {A : Set} → (n : ℕ) → (f : Fin (suc n) → A) →
  lookup (fromℕ n) (tabulate {suc n} f) ≡ f (fromℕ n)
lookup-fromℕ-allFin 0 f = refl
lookup-fromℕ-allFin (suc n) f = lookup-fromℕ-allFin n (f ∘ suc)

fin=1 : (m n : ℕ) →
  fromℕ (suc m + suc n * suc (suc m)) ≡
  fromℕ (suc (m + suc (suc (m + n * suc (suc m)))))
fin=1 m n = toℕ-injective p
  where p = begin (toℕ (fromℕ (suc m + suc n * suc (suc m)))
                 ≡⟨ to-from (suc m + suc n * suc (suc m)) ⟩
                   suc m + suc n * suc (suc m)
                 ≡⟨ refl ⟩
                   suc (m + suc (suc (m + n * suc (suc m))))
                ≡⟨ sym (to-from (suc (m + suc (suc (m + n * suc (suc m)))))) ⟩
                   toℕ (fromℕ (suc (m + suc (suc (m + n * suc (suc m)))))) ∎)
            where open ≡-Reasoning

concat-map-map-tabulate : (m n : ℕ) → (f : Fin m × Fin n → Fin (m * n)) →
  concatV (mapV (λ b → mapV (λ d → f (b , d)) (allFin n)) (allFin m)) ≡
  tabulate (λ k → f (fin-project m n k))
concat-map-map-tabulate m n f =
  begin (concatV (mapV (λ b → mapV (λ d → f (b , d)) (allFin n)) (allFin m))
       ≡⟨ cong concatV (sym (tabulate-∘ (λ b → mapV (λ d → f (b , d)) (allFin n)) id)) ⟩
         concatV (tabulate (λ b → mapV (λ d → f (b , d)) (allFin n)))
       ≡⟨ cong concatV
            (finext (λ b → sym (tabulate-∘ (λ d → f (b , d)) id))) ⟩
         concatV (tabulate (λ b → tabulate (λ d → f (b , d))))
       ≡⟨ tabulate-concat f ⟩
         tabulate (λ k → f (fin-project m n k)) ∎)
  where open ≡-Reasoning

fin-project-2 : (n m : ℕ) →
 fin-project (suc (suc n)) (suc (suc m)) (fromℕ (suc m + suc n * suc (suc m)))
 ≡ (fromℕ (suc n) , fromℕ (suc m))
fin-project-2 n m with toℕ (fromℕ (suc m + suc n * suc (suc m))) divMod (suc (suc m))
fin-project-2 n m | result q r k≡r+q*sn with suc (suc n) ≤? q
fin-project-2 n m | result q r k≡r+q*sn | yes p =
  ⊥-elim (absurd (suc n) (suc m) q r (fromℕ (suc m + suc n * suc (suc m))) k≡r+q*sn p)
fin-project-2 n m | result q r k≡r+q*sn | no ¬p =
  let (b= , d=) = max-b-d n m (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) r pr
  in cong₂ _,_
       (toℕ-injective (trans b= (sym (to-from (suc n)))))
       (toℕ-injective (trans d= (sym (to-from (suc m)))))
  where
        pr : suc (toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc (suc m) + toℕ r) ≡
             suc (suc n) * suc (suc m)
        pr =
          begin (_
-- agda bug?
-- replacing _ by the actual term:
-- suc (toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc (suc m) + toℕ r)
-- gives an occurs check error
                 ≡⟨ cong
                      (λ x → suc (x * suc (suc m) + toℕ r))
                      (toℕ-fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) ⟩
                 suc (q * suc (suc m) + toℕ r)
                 ≡⟨ cong suc (+-comm (q * suc (suc m)) (toℕ r)) ⟩
                 suc (toℕ r + q * suc (suc m))
                 ≡⟨ cong suc (sym k≡r+q*sn) ⟩
                 suc (suc (toℕ (fromℕ (m + suc (suc (m + n * suc (suc m)))))))
                 ≡⟨ cong
                     (λ x → suc (suc x))
                     (to-from (m + suc (suc (m + n * suc (suc m))))) ⟩
                 suc (suc n) * suc (suc m) ∎)
          where open ≡-Reasoning

-- index (b,d) in matrix becomes (d,b) in transpose
-- And yes, it is obvious:
-- (b*n+d)*m = b*n*m + d*m            -- expand
--           = b*(n*m -1) + b*1 + d*m -- add 0 = b*1 - b*1
--           = b + d*m                -- modulus

num-lem : (m n : ℕ) → (b : Fin (suc (suc m))) → (d : Fin (suc (suc n))) →
  (((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m))) ≡
  (toℕ d * suc (suc m) + toℕ b) + toℕ b * suc (m + suc n * suc (suc m))
num-lem m n b d =
  begin (((toℕ b * suc (suc n)) + toℕ d) * suc (suc m)
        ≡⟨ distribʳ-*-+ (suc (suc m)) (toℕ b * suc (suc n)) (toℕ d) ⟩
         (toℕ b * suc (suc n)) * suc (suc m) + toℕ d * suc (suc m)
        ≡⟨ cong
            (λ x → x + toℕ d * suc (suc m))
            (trans
              (*-assoc (toℕ b) (suc (suc n)) (suc (suc m)))
              (*-comm (toℕ b) (suc (suc n) * suc (suc m)))) ⟩
         (suc (suc n) * suc (suc m)) * toℕ b + toℕ d * suc (suc m)
        ≡⟨ refl ⟩
         suc (suc m + suc n * suc (suc m)) * toℕ b + toℕ d * suc (suc m)
        ≡⟨ refl ⟩
         (toℕ b + (suc m + suc n * suc (suc m)) * toℕ b) + toℕ d * suc (suc m)
         ≡⟨ cong
              (λ x → x + toℕ d * suc (suc m))
              (+-comm (toℕ b) ((suc m + suc n * suc (suc m)) * toℕ b)) ⟩
         ((suc m + suc n * suc (suc m)) * toℕ b + toℕ b) + toℕ d * suc (suc m)
        ≡⟨ +-assoc
            ((suc m + suc n * suc (suc m)) * toℕ b)
            (toℕ b)
            (toℕ d * suc (suc m)) ⟩
         (suc m + suc n * suc (suc m)) * toℕ b + (toℕ b + toℕ d * suc (suc m))
        ≡⟨ cong₂ _+_
            (*-comm (suc m + suc n * suc (suc m)) (toℕ b))
            (+-comm (toℕ b) (toℕ d * suc (suc m))) ⟩
        toℕ b * (suc m + suc n * suc (suc m)) + (toℕ d * suc (suc m) + toℕ b)
        ≡⟨ +-comm
             (toℕ b * (suc m + suc n * suc (suc m)))
             (toℕ d * suc (suc m) + toℕ b) ⟩
        (toℕ d * suc (suc m) + toℕ b) + toℕ b * (suc m + suc n * suc (suc m)) ∎)
  where open ≡-Reasoning

mod-lem : (m n : ℕ) → (b : Fin (suc (suc m))) → (d : Fin (suc (suc n))) →
      (leq : suc (toℕ d * suc (suc m) + toℕ b) ≤ suc m + suc n * suc (suc m)) →
      ((((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m)))
        mod (suc m + suc n * suc (suc m)))
    ≡ inject≤ (fromℕ (toℕ d * suc (suc m) + toℕ b)) leq
mod-lem m n b d leq =
  begin (((((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m)))
               mod (suc m + suc n * suc (suc m)))
         ≡⟨ cong
             (λ x → x mod (suc m + suc n * suc (suc m)))
             (num-lem m n b d) ⟩
         (((toℕ d * suc (suc m) + toℕ b) + (toℕ b * (suc m + suc n * suc (suc m))))
               mod (suc m + suc n * suc (suc m)))
          ≡⟨ cong
              (λ x → ((x + (toℕ b * (suc m + suc n * suc (suc m))))
                     mod (suc m + suc n * suc (suc m))))
             (trans
                (sym (to-from (toℕ d * suc (suc m) + toℕ b)))
                (sym (inject≤-lemma (fromℕ (toℕ d * suc (suc m) + toℕ b)) leq) )) ⟩
         (((toℕ (inject≤ (fromℕ (toℕ d * suc (suc m) + toℕ b)) leq)) +
           (toℕ b * (suc m + suc n * suc (suc m))))
           mod (suc m + suc n * suc (suc m)))
          ≡⟨ mod-lemma (toℕ b) (m + suc n * suc (suc m))
              (inject≤ (fromℕ (toℕ d * suc (suc m) + toℕ b)) leq) ⟩
         inject≤ (fromℕ (toℕ d * suc (suc m) + toℕ b)) leq ∎)
  where open ≡-Reasoning

not-max-b-d : (m n : ℕ) (b : Fin (suc (suc m))) (d : Fin (suc (suc n)))
  (p≠ : ¬ suc (toℕ b * suc (suc n) + toℕ d) ≡ suc (suc m) * suc (suc n)) →
   suc (toℕ b * suc (suc n) + toℕ d) ≤ suc n + suc m * suc (suc n)
not-max-b-d m n b d p≠ with
      cmp (suc (toℕ b * suc (suc n) + toℕ d)) (suc (suc m) * suc (suc n))
... | tri< a ¬b ¬c = ≤-pred a
... | tri≈ ¬a b≡ ¬c = ⊥-elim (p≠ b≡)
... | tri> ¬a ¬b c = ⊥-elim (1+n≰n contra)
  where contra = begin (suc (suc (suc m) * suc (suc n))
                       ≤⟨ c ⟩
                        suc (toℕ b * suc (suc n) + toℕ d)
                       ≡⟨ sym (+-suc (toℕ b * suc (suc n)) (toℕ d)) ⟩
                        toℕ b * suc (suc n) + suc (toℕ d)
                       ≤⟨ cong+l≤ (bounded d) (toℕ b * suc (suc n)) ⟩
                        toℕ b * suc (suc n) + suc (suc n)
                       ≤⟨ cong+r≤
                           (cong*r≤ (bounded' (suc m) b) (suc (suc n)))
                           (suc (suc n)) ⟩
                        suc m * suc (suc n) + suc (suc n)
                       ≡⟨ +-comm (suc m * suc (suc n)) (suc (suc n)) ⟩
                        suc (suc m) * suc (suc n) ∎)
                 where open ≤-Reasoning

not-max-b-d' : (m n : ℕ) (b : Fin (suc (suc m))) (d : Fin (suc (suc n)))
  (p≠ : ¬ suc (toℕ b * suc (suc n) + toℕ d) ≡ suc (suc m) * suc (suc n)) →
  (¬ suc (toℕ d * suc (suc m) + toℕ b) ≡ suc (suc n) * suc (suc m))
not-max-b-d' m n b d p≠ with
  (suc (toℕ d * suc (suc m) + toℕ b)) ≟ (suc (suc n) * suc (suc m))
... | no ¬w = ¬w
... | yes w =
  let (d≡sn , b≡sm) = max-b-d n m d b w in ⊥-elim (p≠ (contra b≡sm d≡sn))
  where contra : (b≡sm : toℕ b ≡ suc m) (d≡sn : toℕ d ≡ suc n) →
                 suc (toℕ b * suc (suc n) + toℕ d) ≡ suc (suc m) * suc (suc n)
        contra b≡sm d≡sn =
          begin (suc (toℕ b * suc (suc n) + toℕ d)
                ≡⟨ cong₂ (λ x y → suc (x * suc (suc n) + y)) b≡sm d≡sn ⟩
                 suc (suc m * suc (suc n) + suc n)
                ≡⟨ sym (+-suc (suc m * suc (suc n)) (suc n)) ⟩
                 suc m * suc (suc n) + suc (suc n)
                ≡⟨  +-comm (suc m * suc (suc n)) (suc (suc n)) ⟩
                 suc (suc m) * suc (suc n) ∎)
          where open ≡-Reasoning

inject-mod : (m n : ℕ) (b : Fin (suc (suc m))) (d : Fin (suc (suc n)))
     (leq : suc (toℕ b * suc (suc n) + toℕ d) ≤ suc n + suc m * suc (suc n)) →
        inject≤
          (((toℕ d * suc (suc m) + toℕ b) * suc (suc n)) mod
             (suc n + suc m * suc (suc n)))
          (i≤si (suc n + suc m * suc (suc n)))
      ≡ inject≤
           (fromℕ (toℕ b * suc (suc n) + toℕ d))
           (i*n+k≤m*n b d)
inject-mod m n b d leq =
   begin (inject≤
            (((toℕ d * suc (suc m) + toℕ b) * suc (suc n)) mod
             (suc n + suc m * suc (suc n)))
            (i≤si (suc n + suc m * suc (suc n)))
        ≡⟨ cong₂D!
             inject≤
             (sym (mod-lem n m d b leq))
             (≤-proof-irrelevance
               (subst
                 (λ _ →
                   suc n + suc m * suc (suc n) ≤ suc (suc n + suc m * suc (suc n)))
                 (sym (mod-lem n m d b leq))
                 (i≤si (suc n + suc m * suc (suc n))))
               (i≤si (suc n + suc m * suc (suc n)))) ⟩
          inject≤
            (inject≤ (fromℕ (toℕ  b * suc (suc n) + toℕ d)) leq)
            (i≤si (suc n + suc m * suc (suc n)))
        ≡⟨ toℕ-injective
            (trans
              (inject≤-lemma
                (inject≤ (fromℕ (toℕ b * suc (suc n) + toℕ d)) leq)
                (i≤si (suc n + suc m * suc (suc n))))
              (trans
                (inject≤-lemma (fromℕ (toℕ b * suc (suc n) + toℕ d)) leq)
                (sym (inject≤-lemma
                       (fromℕ (toℕ b * suc (suc n) + toℕ d))
                       (i*n+k≤m*n b d))))) ⟩
         inject≤
           (fromℕ (toℕ b * suc (suc n) + toℕ d))
           (i*n+k≤m*n b d) ∎)
   where open ≡-Reasoning

fin-project-3 : (m n : ℕ) (b : Fin (suc (suc m))) (d : Fin (suc (suc n))) →
  (p≠ : ¬ suc (toℕ d * suc (suc m) + toℕ b) ≡ suc (suc n) * suc (suc m)) →
  fin-project (suc (suc n)) (suc (suc m))
    (inject≤
      ((((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m))) mod
       (suc m + suc n * suc (suc m)))
      (i≤si (suc m + suc n * suc (suc m))))
  ≡ (d , b)
fin-project-3 m n b d p≠ with
  (toℕ (inject≤
         ((((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m))) mod
          (suc m + suc n * suc (suc m)))
         (i≤si (suc m + suc n * suc (suc m))))) divMod (suc (suc m))
fin-project-3 m n b d p≠ | result q r k≡r+q*sn with suc (suc n) ≤? q
fin-project-3 m n b d p≠ | result q r k≡r+q*sn | yes p =
  ⊥-elim (absurd (suc n) (suc m) q r
           (inject≤
             ((((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m))) mod
               (suc m + suc n * suc (suc m)))
             (i≤si (suc m + suc n * suc (suc m))))
             k≡r+q*sn
             p)
fin-project-3 m n b d p≠ | result q r k≡r+q*sn | no ¬p =
  let (r≡b , q≡d) = addMul-lemma′ q (toℕ d) (suc m) r b (sym simplified)
  in cong₂ _,_ (toℕ-injective (trans (toℕ-fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) q≡d)) r≡b
  where simplified : toℕ d * suc (suc m) + toℕ b ≡ q * suc (suc m) + toℕ r
        simplified = begin (toℕ d * suc (suc m) + toℕ b
                            ≡⟨ sym (to-from (toℕ d * suc (suc m) + toℕ b)) ⟩
                           toℕ (fromℕ (toℕ d * suc (suc m) + toℕ b))
                           ≡⟨ sym (inject≤-lemma
                                    (fromℕ (toℕ d * suc (suc m) + toℕ b))
                                    (i*n+k≤m*n d b)) ⟩
                           toℕ (inject≤
                             (fromℕ (toℕ d * suc (suc m) + toℕ b))
                             (i*n+k≤m*n d b))
                           ≡⟨ cong toℕ
                                (sym (inject-mod n m d b (not-max-b-d n m d b p≠))) ⟩
                           toℕ (inject≤
                             ((((toℕ b * suc (suc n)) + toℕ d) * (suc (suc m))) mod
                               (suc m + suc n * suc (suc m)))
                             (i≤si (suc m + suc n * suc (suc m))))
                           ≡⟨ k≡r+q*sn ⟩
                           toℕ r + q * suc (suc m)
                           ≡⟨ +-comm (toℕ r) (q * suc (suc m)) ⟩
                           q * suc (suc m) + toℕ r ∎)
                     where open ≡-Reasoning

transpose2 : (m n : ℕ) (i : Fin (m * n)) →
  let fin-result b d dec dec' = fin-divMod m n i
      fin-result bt dt dect dec't =
        fin-divMod n m (subst Fin (*-comm m n) (transposeIndex m n b d)) in
  toℕ (transposeIndex n m bt dt) ≡ toℕ i
transpose2 m n i =
  let fin-result b d dec dec' = fin-divMod m n i
      fin-result bt dt dect dec't =
        fin-divMod n m (subst Fin (*-comm m n) (transposeIndex m n b d))
      (dbt≡ , bdt≡) = fin-addMul-lemma n m d bt b dt pr
  in fpr
  where pr = let fin-result b d dec dec' = fin-divMod m n i
                 fin-result bt dt dect dec't =
                   fin-divMod n m (subst Fin (*-comm m n) (transposeIndex m n b d)) in
             begin (toℕ d * m + toℕ b
                   ≡⟨ sym (to-from _) ⟩
                   toℕ (fromℕ (toℕ d * m + toℕ b))
                   ≡⟨ sym (inject≤-lemma _ _) ⟩
                   toℕ (transposeIndex m n b d)
                   ≡⟨ sym (toℕ-fin (m * n) (n * m) (*-comm m n)
                           (transposeIndex m n b d)) ⟩
                   toℕ (subst Fin (*-comm m n) (transposeIndex m n b d))
                   ≡⟨ dect ⟩
                   toℕ dt + toℕ bt * m
                   ≡⟨ +-comm (toℕ dt) (toℕ bt * m) ⟩
                   toℕ bt * m + toℕ dt ∎)
             where open ≡-Reasoning
        fpr = let fin-result b d dec dec' = fin-divMod m n i
                  fin-result bt dt dect dec't =
                    fin-divMod n m (subst Fin (*-comm m n) (transposeIndex m n b d))
                  (dbt≡ , bdt≡) = fin-addMul-lemma n m d bt b dt pr in
              begin (toℕ (transposeIndex n m bt dt)
                   ≡⟨ inject≤-lemma _ _ ⟩
                     toℕ (fromℕ (toℕ dt * n + toℕ bt))
                   ≡⟨ to-from _ ⟩
                     toℕ dt * n + toℕ bt
                   ≡⟨ cong₂ (λ x y → toℕ x * n + toℕ y)
                        (sym bdt≡) (sym dbt≡) ⟩
                     toℕ b * n + toℕ d
                   ≡⟨ +-comm (toℕ b * n) (toℕ d) ⟩
                     toℕ d + toℕ b * n
                   ≡⟨ sym dec ⟩
                     toℕ i ∎)
              where open ≡-Reasoning

lookup-transpose : (m n : ℕ) (i : Fin (m * n)) →
  lookup
    (lookup i
      (concatV
        (mapV (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
        (allFin m))))
    (subst Cauchy (*-comm n m)
      (concatV
        (mapV (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
        (allFin n))))
  ≡ i
lookup-transpose m n i =
  let fin-result b d dec dec' = fin-divMod m n i
      fin-result bt dt dect dect' =
        fin-divMod n m (subst Fin (*-comm m n) (transposeIndex m n b d)) in
  begin (lookup
          (lookup i
            (concatV
              (mapV (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
              (allFin m))))
            (subst Cauchy (*-comm n m)
              (concatV
                (mapV (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
                (allFin n))))
       ≡⟨ cong (λ x → lookup x
                 (subst Cauchy (*-comm n m)
                   (concatV
                     (mapV
                        (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
                        (allFin n)))))
           (trans (lookup-2d m n i (allFin m) (allFin n)
                    (λ {(b , d) → transposeIndex m n b d}))
                  (cong₂ (transposeIndex m n)
                    (lookup-allFin b) (lookup-allFin d))) ⟩
         lookup
            (transposeIndex m n b d)
            (subst Cauchy (*-comm n m)
              (concatV
                (mapV (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
                (allFin n))))
       ≡⟨ lookup-subst-1
           (transposeIndex m n b d)
           (concatV
             (mapV
               (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
               (allFin n)))
           (*-comm n m)
           (*-comm m n)
           (proof-irrelevance (sym (*-comm n m)) (*-comm m n)) ⟩
         subst Fin (*-comm n m)
           (lookup
             (subst Fin (*-comm m n) (transposeIndex m n b d))
             (concatV
               (mapV
                 (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
                 (allFin n))))
       ≡⟨ cong (λ x → subst Fin (*-comm n m) x)
            (trans
              (lookup-2d n m (subst Fin (*-comm m n) (transposeIndex m n b d))
                (allFin n) (allFin m)
                (λ {(d , b) → transposeIndex n m d b}))
              (cong₂ (transposeIndex n m)
                (lookup-allFin bt) (lookup-allFin dt))) ⟩
         subst Fin (*-comm n m) (transposeIndex n m bt dt)
       ≡⟨ toℕ-injective
           (trans
             (toℕ-fin (n * m) (m * n) (*-comm n m) (transposeIndex n m bt dt))
             (transpose2 m n i)) ⟩
         i ∎)
  where open ≡-Reasoning

swap⋆idemp : (m n : ℕ) →
  scompcauchy
    (swap⋆cauchy m n)
    (subst Cauchy (*-comm n m) (swap⋆cauchy n m))
  ≡
  allFin (m * n)
swap⋆idemp m n =
  begin (scompcauchy
           (concatV
             (mapV
               (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
               (allFin m)))
           (subst Cauchy (*-comm n m)
             (concatV
               (mapV
                 (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
                 (allFin n))))
         ≡⟨ refl ⟩
         tabulate (λ i →
           lookup
             (lookup i
               (concatV
                 (mapV
                   (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
                   (allFin m))))
             (subst Cauchy (*-comm n m)
               (concatV
                 (mapV
                   (λ d → mapV (λ b → transposeIndex n m d b) (allFin m))
                   (allFin n)))))
         ≡⟨ finext (lookup-transpose m n) ⟩
         allFin (m * n) ∎)
  where open ≡-Reasoning

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


------------------------------------------------------------------------
-- A variant of Coherently that is defined without the use of
-- coinduction
------------------------------------------------------------------------

{-# OPTIONS --cubical #-}

import Equality.Path as P

module Lens.Non-dependent.Higher.Coherently.Not-coinductive
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude

open import Container.Indexed equality-with-J
open import Container.Indexed.M.Function equality-with-J
open import H-level.Truncation.Propositional.One-step eq using (∥_∥¹)

private
  variable
    a b p : Level

-- A container that is used to define Coherently.

Coherently-container :
  {B : Type b}
  (P : {A : Type a} → (A → B) → Type p)
  (step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B) →
  Container (∃ λ (A : Type a) → A → B) p lzero
Coherently-container P step = λ where
  .Shape (_ , f)               → P f
  .Position _                  → ⊤
  .index {o = A , f} {s = p} _ → ∥ A ∥¹ , step f p

-- A variant of Coherently, defined using an indexed container.

Coherently :
  {A : Type a} {B : Type b}
  (P : {A : Type a} → (A → B) → Type p)
  (step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B) →
  (f : A → B) →
  Type (lsuc a ⊔ b ⊔ p)
Coherently P step f =
  M (Coherently-container P step) (_ , f)


-- Andreas, 2013-02-27 issue reported by Nisse
-- {-# OPTIONS -v tc.polarity:100 -v tc.pos:100 #-}
module Issue802 where

data I : Set where
  i : I

mutual

  data P : I → Set where
    p : (x : I) → Q x x → P x

  Q : I → I → Set
  Q i = P
  -- Polarity of Q should be mixed for both arguments.

f : (x y : I) → Q x y → P y
f i _ q = q

data R (x : I) : P x → Set where
  r : (q : Q x x) → R _ (f x _ q) → R x (p x q)

-- Agda should solve the two meta variables in the type of r.


module SystemF.BigStep.Types where

open import Prelude

-- types are indexed by the number of open tvars
infixl 10 _⇒_
data Type (n : ℕ) : Set where
  Unit : Type n
  ν    : (i : Fin n) → Type n
  _⇒_  : Type n → Type n → Type n
  ∀'   : Type (suc n) → Type n

open import Data.Fin.Substitution
open import Data.Vec

module App {T} (l : Lift T Type )where
  open Lift l hiding (var)
  _/_  : ∀ {m n} → Type m → Sub T m n → Type n
  Unit / s = Unit
  ν i / s = lift (lookup i s)
  (a ⇒ b) / s = (a / s) ⇒ (b / s)
  ∀' x / s = ∀' (x / (s ↑))

  open Application (record { _/_ = _/_ }) using (_/✶_)

  open import Data.Star

  Unit-/✶-↑✶ : ∀ k {m n} (ρs : Subs T m n) → Unit /✶ ρs ↑✶ k ≡ Unit
  Unit-/✶-↑✶ k ε = refl
  Unit-/✶-↑✶ k (x ◅ ρs) = cong₂ _/_ (Unit-/✶-↑✶ k ρs) refl

  ∀-/✶-↑✶ : ∀ k {m n t} (ρs : Subs T m n) →
            ∀' t /✶ ρs ↑✶ k ≡ ∀' (t /✶ ρs ↑✶ suc k)
  ∀-/✶-↑✶ k ε        = refl
  ∀-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (∀-/✶-↑✶ k ρs) refl

  ⇒-/✶-↑✶ : ∀ k {m n t₁ t₂} (ρs : Subs T m n) →
            t₁ ⇒ t₂ /✶ ρs ↑✶ k ≡ (t₁ /✶ ρs ↑✶ k) ⇒ (t₂ /✶ ρs ↑✶ k)
  ⇒-/✶-↑✶ k ε        = refl
  ⇒-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (⇒-/✶-↑✶ k ρs) refl

tmSubst : TermSubst Type
tmSubst = record { var = ν; app = App._/_ }

open TermSubst tmSubst hiding (var; subst) public

module Lemmas where

  open import Data.Fin.Substitution.Lemmas

  tyLemmas : TermLemmas Type
  tyLemmas = record
    { termSubst = tmSubst
    ; app-var   = refl
    ; /✶-↑✶     = Lemma./✶-↑✶
    }
    where
    module Lemma {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} where

      open Lifted lift₁ using () renaming (_↑✶_ to _↑✶₁_; _/✶_ to _/✶₁_)
      open Lifted lift₂ using () renaming (_↑✶_ to _↑✶₂_; _/✶_ to _/✶₂_)

      /✶-↑✶ : ∀ {m n} (ρs₁ : Subs T₁ m n) (ρs₂ : Subs T₂ m n) →
              (∀ k x → ν x /✶₁ ρs₁ ↑✶₁ k ≡ ν x /✶₂ ρs₂ ↑✶₂ k) →
              ∀ k t → t /✶₁ ρs₁ ↑✶₁ k ≡ t /✶₂ ρs₂ ↑✶₂ k
      /✶-↑✶ ρs₁ ρs₂ hyp k Unit =
        begin _ ≡⟨ App.Unit-/✶-↑✶ _ k ρs₁ ⟩ Unit ≡⟨ sym $ App.Unit-/✶-↑✶ _ k ρs₂ ⟩ _ ∎
      /✶-↑✶ ρs₁ ρs₂ hyp k (ν i) = hyp k i
      /✶-↑✶ ρs₁ ρs₂ hyp k (a ⇒ b) = begin
        _ ≡⟨ App.⇒-/✶-↑✶ _ k ρs₁ ⟩
        (a /✶₁ ρs₁ ↑✶₁ k) ⇒ (b /✶₁ ρs₁ ↑✶₁ k) ≡⟨ cong₂ _⇒_ (/✶-↑✶ ρs₁ ρs₂ hyp k a)
                                                           ((/✶-↑✶ ρs₁ ρs₂ hyp k b)) ⟩
        (a /✶₂ ρs₂ ↑✶₂ k) ⇒ (b /✶₂ ρs₂ ↑✶₂ k) ≡⟨ sym $ App.⇒-/✶-↑✶ _ k ρs₂ ⟩
        _ ∎
      /✶-↑✶ ρs₁ ρs₂ hyp k (∀' x) = begin
        _ ≡⟨ App.∀-/✶-↑✶ _ k ρs₁ ⟩
          ∀' (x /✶₁ ρs₁ ↑✶₁ (suc k)) ≡⟨ cong ∀' (/✶-↑✶ ρs₁ ρs₂ hyp (suc k) x) ⟩
        ∀' (x /✶₂ ρs₂ ↑✶₂ (suc k)) ≡⟨ sym $ App.∀-/✶-↑✶ _ k ρs₂ ⟩
        _ ∎

  open TermLemmas tyLemmas public hiding (var)


------------------------------------------------------------------------
-- Pushouts, defined using a HIT
------------------------------------------------------------------------

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

-- This module follows the HoTT book rather closely.

-- The module is parametrised by a notion of equality. The higher
-- constructor of the HIT defining pushouts uses path equality, but
-- the supplied notion of equality is used for many other things.

import Equality.Path as P

module Pushout
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J hiding (id; _∘_)
import H-level equality-with-J as H-level
open import H-level.Closure equality-with-J
open import Pointed-type equality-with-J using (Pointed-type)
import Suspension eq as S

private
  variable
    a b l ℓ m p r : Level
    A B           : Type a
    S             : A

-- Spans.

record Span l r m : Type (lsuc (l ⊔ r ⊔ m)) where
  field
    {Left}   : Type l
    {Right}  : Type r
    {Middle} : Type m
    left     : Middle → Left
    right    : Middle → Right

-- Pushouts.

data Pushout (S : Span l r m) : Type (l ⊔ r ⊔ m) where
  inl   : Span.Left  S → Pushout S
  inr   : Span.Right S → Pushout S
  glueᴾ : (x : Span.Middle S) →
          inl (Span.left S x) P.≡ inr (Span.right S x)

-- Glue.

glue : (x : Span.Middle S) →
       _≡_ {A = Pushout S} (inl (Span.left S x)) (inr (Span.right S x))
glue x = _↔_.from ≡↔≡ (glueᴾ x)

-- A dependent eliminator, expressed using paths.

elimᴾ :
  {S : Span l r m} (open Span S)
  (P : Pushout S → Type p)
  (h₁ : (x : Left) → P (inl x))
  (h₂ : (x : Right) → P (inr x)) →
  (∀ x → P.[ (λ i → P (glueᴾ x i)) ] h₁ (left x) ≡ h₂ (right x)) →
  (x : Pushout S) → P x
elimᴾ P h₁ h₂ g = λ where
  (inl x)     → h₁ x
  (inr x)     → h₂ x
  (glueᴾ x i) → g x i

-- A non-dependent eliminator.

recᴾ :
  {S : Span l r m} (open Span S)
  (h₁ : Left → A)
  (h₂ : Right → A) →
  (∀ x → h₁ (left x) P.≡ h₂ (right x)) →
  Pushout S → A
recᴾ = elimᴾ _

-- A dependent eliminator.

elim :
  {S : Span l r m} (open Span S)
  (P : Pushout S → Type p)
  (h₁ : (x : Left) → P (inl x))
  (h₂ : (x : Right) → P (inr x)) →
  (∀ x → subst P (glue x) (h₁ (left x)) ≡ h₂ (right x)) →
  (x : Pushout S) → P x
elim P h₁ h₂ g = elimᴾ P h₁ h₂ (subst≡→[]≡ ∘ g)

elim-glue :
  {S : Span l r m} (open Span S) {P : Pushout S → Type p}
  {h₁ : (x : Left) → P (inl x)}
  {h₂ : (x : Right) → P (inr x)}
  {g : ∀ x → subst P (glue x) (h₁ (left x)) ≡ h₂ (right x)}
  {x : Middle} →
  dcong (elim P h₁ h₂ g) (glue x) ≡ g x
elim-glue = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator.

rec :
  {S : Span l r m} (open Span S)
  (h₁ : Left → A)
  (h₂ : Right → A) →
  (∀ x → h₁ (left x) ≡ h₂ (right x)) →
  Pushout S → A
rec h₁ h₂ g = recᴾ h₁ h₂ (_↔_.to ≡↔≡ ∘ g)

rec-glue :
  {S : Span l r m} (open Span S)
  {h₁ : Left → A} {h₂ : Right → A}
  {g : ∀ x → h₁ (left x) ≡ h₂ (right x)}
  {x : Middle} →
  cong (rec h₁ h₂ g) (glue x) ≡ g x
rec-glue = cong-≡↔≡ (refl _)

-- Cocones.

Cocone : Span l r m → Type a → Type (a ⊔ l ⊔ r ⊔ m)
Cocone S A =
  ∃ λ (left  : Left  → A) →
  ∃ λ (right : Right → A) →
    (x : Middle) → left (Span.left S x) ≡ right (Span.right S x)
  where
  open Span S using (Left; Right; Middle)

-- Some projection functions for cocones.

module Cocone (c : Cocone S A) where
  open Span S using (Left; Right; Middle)

  left : Left → A
  left = proj₁ c

  right : Right → A
  right = proj₁ (proj₂ c)

  left-left≡right-right :
    (x : Middle) → left (Span.left S x) ≡ right (Span.right S x)
  left-left≡right-right = proj₂ (proj₂ c)

-- A universal property for pushouts.

Pushout→↔Cocone : (Pushout S → A) ↔ Cocone S A
Pushout→↔Cocone {S = S} {A = A} = record
  { surjection = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to-from
    }
  ; left-inverse-of = from-to
  }
  where
  open Span S

  to : (Pushout S → A) → Cocone S A
  to f = f ∘ inl , f ∘ inr , cong f ∘ glue

  from : Cocone S A → (Pushout S → A)
  from c = rec
    (Cocone.left c)
    (Cocone.right c)
    (Cocone.left-left≡right-right c)

  to-from : ∀ c → to (from c) ≡ c
  to-from c = cong (λ x → _ , _ , x) $ ⟨ext⟩ λ x →
    cong (from c) (glue x)            ≡⟨ rec-glue ⟩∎
    Cocone.left-left≡right-right c x  ∎

  from-to : ∀ f → from (to f) ≡ f
  from-to f = ⟨ext⟩ $ elim
    _
    (λ _ → refl _)
    (λ _ → refl _)
    (λ x →
       subst (λ y → from (to f) y ≡ f y) (glue x) (refl _)                    ≡⟨ subst-in-terms-of-trans-and-cong ⟩

       trans (sym (cong (from (to f)) (glue x)))
         (trans (refl _) (cong f (glue x)))                                   ≡⟨ cong (trans _) $ trans-reflˡ _ ⟩

       trans (sym (cong (from (to f)) (glue x))) (cong f (glue x))            ≡⟨ cong (λ eq → trans (sym eq) (cong f (glue x))) rec-glue ⟩

       trans (sym (Cocone.left-left≡right-right (to f) x)) (cong f (glue x))  ≡⟨⟩

       trans (sym (cong f (glue x))) (cong f (glue x))                        ≡⟨ trans-symˡ _ ⟩∎

       refl _                                                                 ∎)

-- Joins.

Join : Type a → Type b → Type (a ⊔ b)
Join A B = Pushout (record
  { Middle = A × B
  ; left   = proj₁
  ; right  = proj₂
  })

-- Join is symmetric.

Join-symmetric : Join A B ≃ Join B A
Join-symmetric = Eq.↔→≃
  to
  to
  to-to
  to-to
  where
  to : Join A B → Join B A
  to = rec inr inl (sym ∘ glue ∘ swap)

  to-to : (x : Join A B) → to (to x) ≡ x
  to-to =
    elim _ (λ _ → refl _) (λ _ → refl _)
      (λ p →
         subst (λ x → to (to x) ≡ x) (glue p) (refl _)         ≡⟨ subst-in-terms-of-trans-and-cong ⟩

         trans (sym (cong (to ∘ to) (glue p)))
           (trans (refl _) (cong id (glue p)))                 ≡⟨ cong₂ (trans ∘ sym)
                                                                    (sym $ cong-∘ _ _ _)
                                                                    (trans (trans-reflˡ _) $
                                                                     sym $ cong-id _) ⟩

         trans (sym (cong to (cong to (glue p)))) (glue p)     ≡⟨ cong (flip trans _) $ cong (sym ∘ cong to) rec-glue ⟩

         trans (sym (cong to (sym (glue (swap p))))) (glue p)  ≡⟨ cong (flip trans _) $ cong sym $ cong-sym _ _ ⟩

         trans (sym (sym (cong to (glue (swap p))))) (glue p)  ≡⟨ cong (flip trans _) $ sym-sym _ ⟩

         trans (cong to (glue (swap p))) (glue p)              ≡⟨ cong (flip trans _) rec-glue ⟩

         trans (sym (glue (swap (swap p)))) (glue p)           ≡⟨⟩

         trans (sym (glue p)) (glue p)                         ≡⟨ trans-symˡ _ ⟩∎

         refl _                                                ∎)

-- The empty type is a right identity for Join.

Join-⊥ʳ : Join A (⊥ {ℓ = ℓ}) ≃ A
Join-⊥ʳ = Eq.↔→≃
  (rec id ⊥-elim (λ { (_ , ()) }))
  inl
  refl
  (elim _ (λ _ → refl _) (λ ()) (λ { (_ , ()) }))

-- The empty type is a left identity for Join.

Join-⊥ˡ : Join (⊥ {ℓ = ℓ}) A ≃ A
Join-⊥ˡ {A = A} =
  Join ⊥ A  ↝⟨ Join-symmetric ⟩
  Join A ⊥  ↝⟨ Join-⊥ʳ ⟩□
  A         □

-- Cones.

Cone : {A : Type a} {B : Type b} → (A → B) → Type (a ⊔ b)
Cone f = Pushout (record
  { Left  = ⊤
  ; right = f
  })

-- Wedges.

Wedge : Pointed-type a → Pointed-type b → Type (a ⊔ b)
Wedge (A , a) (B , b) =
  Pushout (record
    { Middle = ⊤
    ; left   = const a
    ; right  = const b
    })

-- Smash products.

Smash-product : Pointed-type a → Pointed-type b → Type (a ⊔ b)
Smash-product PA@(A , a) PB@(B , b) = Cone f
  where
  f : Wedge PA PB → A × B
  f = rec (_, b) (a ,_) (λ _ → refl _)

-- Suspensions.

Susp : Type a → Type a
Susp A = Pushout (record
  { Left   = ⊤
  ; Middle = A
  ; Right  = ⊤
  })

-- These suspensions are equivalent to the ones defined in Suspension.

Susp≃Susp : Susp A ≃ S.Susp A
Susp≃Susp = Eq.↔⇒≃ (record
  { surjection = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to∘from
    }
  ; left-inverse-of = from∘to
  })
  where
  to : Susp A → S.Susp A
  to = recᴾ (λ _ → S.north) (λ _ → S.south) S.meridianᴾ

  from : S.Susp A → Susp A
  from = S.recᴾ (inl _) (inr _) glueᴾ

  to∘from : ∀ x → to (from x) ≡ x
  to∘from =
    _↔_.from ≡↔≡ ∘
    S.elimᴾ _ P.refl P.refl (λ a i _ → S.meridianᴾ a i)

  from∘to : ∀ x → from (to x) ≡ x
  from∘to =
    _↔_.from ≡↔≡ ∘
    elimᴾ _ (λ _ → P.refl) (λ _ → P.refl) (λ a i _ → glueᴾ a i)


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Covec type and some operations
------------------------------------------------------------------------

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

module Codata.Covec where

open import Size

open import Codata.Thunk using (Thunk; force)
open import Codata.Conat as Conat
open import Codata.Conat.Bisimilarity
open import Codata.Conat.Properties
open import Codata.Cofin as Cofin using (Cofin; zero; suc)
open import Codata.Colist as Colist using (Colist ; [] ; _∷_)
open import Codata.Stream as Stream using (Stream ; _∷_)
open import Function

data Covec {ℓ} (A : Set ℓ) (i : Size) : Conat ∞ → Set ℓ where
  []  : Covec A i zero
  _∷_ : ∀ {n} → A → Thunk (λ i → Covec A i (n .force)) i → Covec A i (suc n)

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

 head : ∀ {n i} → Covec A i (suc n) → A
 head (x ∷ _) = x

 tail : ∀ {n} → Covec A ∞ (suc n) → Covec A ∞ (n .force)
 tail (_ ∷ xs) = xs .force

 lookup : ∀ {n} → Cofin n → Covec A ∞ n → A
 lookup zero    = head
 lookup (suc k) = lookup k ∘′ tail

 replicate : ∀ {i} → (n : Conat ∞) → A → Covec A i n
 replicate zero    a = []
 replicate (suc n) a = a ∷ λ where .force → replicate (n .force) a

 cotake : ∀ {i} → (n : Conat ∞) → Stream A i → Covec A i n
 cotake zero    xs       = []
 cotake (suc n) (x ∷ xs) = x ∷ λ where .force → cotake (n .force) (xs .force)

 infixr 5 _++_
 _++_ : ∀ {i m n} → Covec A i m → Covec A i n → Covec A i (m + n)
 []       ++ ys = ys
 (x ∷ xs) ++ ys = x ∷ λ where .force → xs .force ++ ys

 fromColist : ∀ {i} → (xs : Colist A ∞) → Covec A i (Colist.length xs)
 fromColist []       = []
 fromColist (x ∷ xs) = x ∷ λ where .force → fromColist (xs .force)

 toColist : ∀ {i n} → Covec A i n → Colist A i
 toColist []       = []
 toColist (x ∷ xs) = x ∷ λ where .force → toColist (xs .force)

 fromStream : ∀ {i} → Stream A i → Covec A i infinity
 fromStream = cotake infinity

 cast : ∀ {i} {m n} → i ⊢ m ≈ n → Covec A i m → Covec A i n
 cast zero     []       = []
 cast (suc eq) (a ∷ as) = a ∷ λ where .force → cast (eq .force) (as .force)

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

 map : ∀ {i n} (f : A → B) → Covec A i n → Covec B i n
 map f []       = []
 map f (a ∷ as) = f a ∷ λ where .force → map f (as .force)

 ap : ∀ {i n} → Covec (A → B) i n → Covec A i n → Covec B i n
 ap []       []       = []
 ap (f ∷ fs) (a ∷ as) = (f a) ∷ λ where .force → ap (fs .force) (as .force)

 scanl : ∀ {i n} → (B → A → B) → B → Covec A i n → Covec B i (1 ℕ+ n)
 scanl c n []       = n ∷ λ where .force → []
 scanl c n (a ∷ as) = n ∷ λ where
   .force → cast (suc λ where .force → 0ℕ+-identity)
                 (scanl c (c n a) (as .force))

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} where

 zipWith : ∀ {i n} → (A → B → C) → Covec A i n → Covec B i n → Covec C i n
 zipWith f []       []       = []
 zipWith f (a ∷ as) (b ∷ bs) =
   f a b ∷ λ where .force → zipWith f (as .force) (bs .force)


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Weight biased leftist tree that proves both priority and rank    --
-- invariants and uses single-pass merging algorithm.               --
----------------------------------------------------------------------

{-# OPTIONS --sized-types #-}
module SinglePassMerge.CombinedProofs where

open import Basics
open import TwoPassMerge.RankProof
            using    ( makeT-lemma )
            renaming ( proof-1 to proof-1a; proof-2 to proof-2a )
open import SinglePassMerge.RankProof
            using    ( proof-1b; proof-2b )
open import Sized

data Heap : {i : Size} → Priority → Rank → Set where
  empty : {i : Size} {b : Priority} → Heap {↑ i} b zero
  node  : {i : Size} {b : Priority} → (p : Priority) → p ≥ b → {l r : Rank} →
          l ≥ r → Heap {i} p l → Heap {i} p r → Heap {↑ i} b (suc (l + r))

-- Here we combined previously conducted proofs of rank and priority
-- invariants in the same way we did it for two-pass merging algorithm
-- in TwoPassMerge.CombinedProofs. The most important thing here is
-- that we use order function both when comparing priorities and ranks
-- of new subtrees. This gives us evidence that required invariants
-- hold.
merge : {i j : Size} {b : Priority} {l r : Rank} → Heap {i} b l → Heap {j} b r
      → Heap {∞} b (l + r)
merge empty h2 = h2
merge {_} .{_} {b} {suc l} {zero} h1 empty
          = subst (Heap b)
                  (sym (+0 (suc l)))
                  h1
merge .{_} .{_} .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {_} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {_}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  with order p1 p2
  | order l1-rank (r1-rank + suc (l2-rank + r2-rank))
  | order l2-rank (r2-rank + suc (l1-rank + r1-rank))
merge .{↑ i} .{↑ j}  .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i}.{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j} {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  | le p1≤p2
  | ge l1≥r1+h2
  | _
  = subst (Heap b)
          (proof-1a l1-rank r1-rank l2-rank r2-rank)
          (node p1 p1≥b l1≥r1+h2 l1 (merge r1 (node p2 p1≤p2 l2≥r2 l2 r2)))
merge .{↑ i} .{↑ j} .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  | le p1≤p2
  | le l1≤r1+h2
  | _
  = subst (Heap b)
          (proof-1b l1-rank r1-rank l2-rank r2-rank)
          (node p1 p1≥b l1≤r1+h2 (merge r1 (node p2 p1≤p2 l2≥r2 l2 r2)) l1)
merge .{↑ i} .{↑ j}  .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  | ge p1≥p2
  | _
  | ge l2≥r2+h1
  = subst (Heap b)
          (proof-2a l1-rank r1-rank l2-rank r2-rank)
          (node p2 p2≥b l2≥r2+h1 l2 (merge r2 (node p1 p1≥p2 l1≥r1 l1 r1)))
merge .{↑ i} .{↑ j}  .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  | ge p1≥p2
  | _
  | le l2≤r2+h1
  = subst (Heap b)
          (proof-2b l1-rank r1-rank l2-rank r2-rank)
          (node p2 p2≥b l2≤r2+h1 (merge r2 (node p1 p1≥p2 l1≥r1 l1 r1)) l2)


module Oscar.Data.AList.properties {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Category.Category
open import Oscar.Category.Functor
open import Oscar.Category.Morphism
open import Oscar.Category.Semigroupoid
open import Oscar.Category.Semifunctor
open import Oscar.Category.Setoid
open import Oscar.Class.ThickAndThin
open import Oscar.Data.AList FunctionName
open import Oscar.Data.Equality
open import Oscar.Data.Equality.properties
open import Oscar.Data.Fin
open import Oscar.Data.Fin.ThickAndThin
open import Oscar.Data.Maybe
open import Oscar.Data.Nat
open import Oscar.Data.Product
open import Oscar.Data.Term FunctionName
import      Oscar.Data.Term.internal.SubstituteAndSubstitution FunctionName as S
open import Oscar.Data.Term.ThickAndThin FunctionName
open import Oscar.Function

module 𝔊₂ = Category S.𝔾₁
module 𝔉◃ = Functor S.𝔽◂

𝕞₁ = ⇧ AList

module 𝔐₁ = Morphism 𝕞₁

private

  _∙_ : ∀ {m n} → m 𝔐₁.↦ n → ∀ {l} → l 𝔐₁.↦ m → l 𝔐₁.↦ n
  ρ ∙ anil = ρ
  ρ ∙ (σ asnoc t' / x) = (ρ ∙ σ) asnoc t' / x

  ∙-associativity : ∀ {l m} (ρ : l 𝔐₁.↦ m) {n} (σ : n 𝔐₁.↦ _) {o} (τ : o 𝔐₁.↦ _) → (ρ ∙ σ) ∙ τ ≡ ρ ∙ (σ ∙ τ)
  ∙-associativity ρ σ anil = refl
  ∙-associativity ρ σ (τ asnoc t / x) = cong (λ s → s asnoc t / x) (∙-associativity ρ σ τ)

instance

  IsSemigroupoid𝕞₁∙ : IsSemigroupoid 𝕞₁ _∙_
  IsSemigroupoid.extensionality IsSemigroupoid𝕞₁∙ f₁≡f₂ g₁≡g₂ = cong₂ (λ ‵ → _∙_ ‵) g₁≡g₂ f₁≡f₂
  IsSemigroupoid.associativity IsSemigroupoid𝕞₁∙ f g h = ∙-associativity h g f

𝕘₁ : Semigroupoid _ _ _
𝕘₁ = 𝕞₁ , _∙_

private

  ε : ∀ {n} → n 𝔐₁.↦ n
  ε = anil

  ∙-left-identity : ∀ {m n} (σ : AList m n) → ε ∙ σ ≡ σ
  ∙-left-identity anil = refl
  ∙-left-identity (σ asnoc t' / x) = cong (λ σ → σ asnoc t' / x) (∙-left-identity σ)

instance

  IsCategory𝕘₁ε : IsCategory 𝕘₁ ε
  IsCategory.left-identity IsCategory𝕘₁ε = ∙-left-identity
  IsCategory.right-identity IsCategory𝕘₁ε _ = refl

𝔾₁ : Category _ _ _
𝔾₁ = 𝕘₁ , ε

𝕞₂ = 𝔊₂.𝔐
module 𝔐₂ = Morphism 𝕞₂

private

  sub : ∀ {m n} → m 𝔐₁.↦ n → m 𝔊₂.↦ n
  sub anil = i
  sub (σ asnoc t' / x) =  sub σ 𝔊₂.∙ (t' for x)

  fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) → sub (ρ ∙ σ) ≡̇ (sub ρ 𝔊₂.∙ sub σ)
  fact1 ρ anil v = refl
  fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
    where
      t = (t' for x) v
      hyp-on-terms = 𝔉◃.extensionality (fact1 r s) t
      ◃-assoc = 𝔉◃.distributivity (sub s) (sub r) t

𝕘₁,₂ : Semigroupoids _ _ _ _ _ _
𝕘₁,₂ = 𝕘₁ , 𝔊₂.semigroupoid

instance

  IsSemifunctorSub∙◇ : IsSemifunctor 𝕘₁,₂ sub
  IsSemifunctor.extensionality IsSemifunctorSub∙◇ refl _ = refl
  IsSemifunctor.distributivity IsSemifunctorSub∙◇ f g x = fact1 g f x

semifunctorSub∙◇ : Semifunctor _ _ _ _ _ _
semifunctorSub∙◇ = 𝕘₁,₂ , sub

instance

  IsFunctor𝔽 : IsFunctor (𝔾₁ , S.𝔾₁) sub
  IsFunctor.identity IsFunctor𝔽 _ _ = refl

𝔽 : Functor _ _ _ _ _ _
𝔽 = (𝔾₁ , S.𝔾₁) , sub

--   fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) → sub (ρ ∙ σ) ≡̇ (sub ρ ◇ sub σ)
--   fact1 ρ anil v = refl
--   fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
--     where
--       t = (t' for x) v
--       hyp-on-terms = ◃-extensionality (fact1 r s) t
--       ◃-assoc = ◃-associativity (sub s) (sub r) t

-- _∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
--   → ∃ (AList (suc m))
-- (n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

-- flexFlex : ∀ {m} (x y : Fin m) → ∃ (AList m)
-- flexFlex {suc m} x y with check x y
-- ...              | just y' = m , anil asnoc i y' / x
-- ...              | nothing = suc m , anil
-- flexFlex {zero} () _

-- flexRigid : ∀ {m} (x : Fin m) (t : Term m) → Maybe (∃(AList m))
-- flexRigid {suc m} x t with check x t
-- ...                   | just t' = just (m , anil asnoc t' / x)
-- ...                   | nothing = nothing
-- flexRigid {zero} () _


module CategoryTheory.CartesianStrength where

open import CategoryTheory.Categories
open import CategoryTheory.Functor
open import CategoryTheory.BCCCs.Cartesian
open import CategoryTheory.Monad
open import CategoryTheory.Comonad

-- Type class for Cartesian functors
record CartesianFunctor {n}
        {ℂ : Category n} {𝔻 : Category n} (Fn : Functor ℂ 𝔻)
        (ℂ-cart : Cartesian ℂ) (𝔻-cart : Cartesian 𝔻) : Set (lsuc n) where
    private module ℂ = Category ℂ
    private module 𝔻 = Category 𝔻
    open Category 𝔻
    open Functor Fn renaming (omap to F)
    open Cartesian ℂ-cart renaming
        ( ⊤ to ⊤ᶜ ; _⊗_ to _⊗ᶜ_ ; _*_ to _*ᶜ_ ; assoc-right to αᶜ
        ; unit-left to λᶜ ; unit-right to ρᶜ)
    open Cartesian 𝔻-cart renaming
        ( ⊤ to ⊤ᵈ ; _⊗_ to _⊗ᵈ_ ; _*_ to _*ᵈ_; assoc-right to αᵈ
        ; unit-left to λᵈ ; unit-right to ρᵈ)

    field
        -- | Data
        -- F preserves terminal objects (0-ary products)
        u : ⊤ᵈ ~> F ⊤ᶜ
        -- F preserves binary products
        m : ∀(A B : ℂ.obj) -> F A ⊗ᵈ F B ~> F (A ⊗ᶜ B)

        -- | Laws
        -- Naturality conditions
        m-nat₁ : ∀{A B C : ℂ.obj} (f : A ℂ.~> B)
              -> fmap (f *ᶜ ℂ.id) ∘ m A C ≈ m B C ∘ fmap f *ᵈ id
        m-nat₂ : ∀{A B C : ℂ.obj} (f : A ℂ.~> B)
              -> fmap (ℂ.id *ᶜ f) ∘ m C A ≈ m C B ∘ id *ᵈ fmap f

        -- Monoid laws
        associative : ∀{A B C : ℂ.obj} ->
              m A (B ⊗ᶜ C) ∘ (id *ᵈ m B C) ∘ αᵈ
            ≈ fmap αᶜ ∘ m (A ⊗ᶜ B) C ∘ (m A B *ᵈ id)
        unital-right : ∀{A : ℂ.obj} ->
            fmap ρᶜ ∘ m A ⊤ᶜ ∘ (id *ᵈ u) ≈ ρᵈ
        unital-left : ∀{B : ℂ.obj} ->
            fmap λᶜ ∘ m ⊤ᶜ B ∘ (u *ᵈ id) ≈ λᵈ

    -- Canonical distribution morphism
    m⁻¹ : ∀(A B : ℂ.obj) -> F (A ⊗ᶜ B) ~> F A ⊗ᵈ F B
    m⁻¹ A B = Cartesian.⟨_,_⟩ 𝔻-cart (fmap (Cartesian.π₁ ℂ-cart))
                                     (fmap (Cartesian.π₂ ℂ-cart))

-- Type class for Cartesian comonads
record CartesianComonad {n}
        {ℂ : Category n} (C : Comonad ℂ)
        (ℂ-cart : Cartesian ℂ) : Set (lsuc n) where
    open Category ℂ
    open Comonad C
    open Functor W renaming (omap to F)
    open Cartesian ℂ-cart

    field
        -- Cartesian comonads are Cartesian functors
        cart-fun : CartesianFunctor W ℂ-cart ℂ-cart
    open CartesianFunctor cart-fun
    field
        -- | Laws
        u-ε : u ∘ ε.at ⊤ ≈ id
        u-δ : δ.at ⊤ ∘ u ≈ fmap u ∘ u
        m-ε : ∀{A B : obj} -> ε.at (A ⊗ B) ∘ m A B ≈ ε.at A * ε.at B
        m-δ : ∀{A B : obj} -> fmap (m A B) ∘ m (F A) (F B) ∘ δ.at A * δ.at B
                            ≈ δ.at (A ⊗ B) ∘ m A B

-- Type class for W-strong monads (for a Cartesian comonad W)
record WStrongMonad {n}
        {ℂ : Category n} (ℂ-cart : Cartesian ℂ) {Co : Comonad ℂ}
        (Mo : Monad ℂ) (W-cart-com : CartesianComonad Co ℂ-cart)
        : Set (lsuc n) where
    open Category ℂ
    open Comonad Co
    open Monad Mo
    open Functor W renaming (omap to C ; fmap to C-f)
    open Functor T renaming (omap to M ; fmap to M-f)
    open Cartesian ℂ-cart
    open CartesianComonad W-cart-com
    open CartesianFunctor cart-fun

    λᶜ : ∀(A : obj) -> C ⊤ ⊗ A ~> A
    λᶜ _ = π₂

    αᶜ : ∀(A B D : obj) -> (C (A ⊗ B) ⊗ D) ~> (C A ⊗ (C B ⊗ D))
    αᶜ A B D = assoc-right ∘ m⁻¹ A B * id

    field
        -- C-tensorial strength
        st : ∀(A B : obj) -> C A ⊗ M B ~> M (C A ⊗ B)

        -- | Laws
        -- Naturality conditions
        st-nat₁ : ∀{A B D : obj} (f : A ~> B)
               -> M-f (C-f f * id) ∘ st A D ≈ st B D ∘ C-f f * id
        st-nat₂ : ∀{A B D : obj} (f : A ~> B)
               -> M-f (id * f) ∘ st D A ≈ st D B ∘ id * M-f f

        -- Strength and left unit
        st-λ : ∀{A} -> M-f (λᶜ A) ∘ st ⊤ A ≈ λᶜ (M A)
        -- Strength and associativity
        st-α : ∀{A B D} -> st A (C B ⊗ D) ∘ id * st B D ∘ αᶜ A B (M D)
                         ≈ M-f (αᶜ A B D) ∘ st (A ⊗ B) D
        -- Strength and unit
        st-η : ∀{A B} -> st A B ∘ id * η.at B ≈ η.at (C A ⊗ B)
        -- Strength and multiplication
        st-μ : ∀{A B} -> μ.at (C A ⊗ B) ∘ M-f (st A B) ∘ st A (M B)
                       ≈ st A B ∘ (id * μ.at B)


{-# OPTIONS --safe #-}
module Cubical.HITs.Truncation.FromNegTwo where

open import Cubical.HITs.Truncation.FromNegTwo.Base public
open import Cubical.HITs.Truncation.FromNegTwo.Properties public