Updated doc.

Updated doc.

Ignore-this: ea90bf60f58408e68cf3a15d6617c5fc

darcs-hash:20111219052141-3bd4e-f5d3cfb1252093bcb2fb811b494239f0956342d3.gz

------------------------------------------------------------------------------
-- FOT (First Order Theories)
------------------------------------------------------------------------------

-- Code accompanying the paper "Combining Interactive and Automatic
-- Reasoning in First Order Theories of Functional Programs" by Ana
-- Bove, Peter Dybjer, and Andrés Sicard-Ramírez (FoSSaCS 2012).

-- The code presented here does not match the paper exactly.

module README where

------------------------------------------------------------------------------
-- Description

-- Examples of the formalization of first order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Prerequisites and use

-- See http://www1.eafit.edu.co/asicard/code/fotc/.

------------------------------------------------------------------------------
-- Conventions

-- The following modules show the formalization of some first order
-- theories. If the module's name ends in 'I' the module contains
-- interactive proofs, if it ends in 'ATP' the module contains
-- combined proofs, otherwise the module contains definions and/or
-- interactive proofs that are used by the interactive and combined
-- proofs.

------------------------------------------------------------------------------
-- First order theories
------------------------------------------------------------------------------

-- 1. Predicate logic

-- 1.1 Definition of the connectives and quantifiers
open import Common.LogicalConstants
open import PredicateLogic.Constants

-- 1.2 Propositional logic theorems
open import PredicateLogic.Propositional.TheoremsATP
open import PredicateLogic.Propositional.TheoremsI

-- 1.3 Predicate logic theorems
open import PredicateLogic.TheoremsATP
open import PredicateLogic.TheoremsI

-- 1.4 Logical schemas
open import PredicateLogic.SchemasATP

-- 1.5 Non-empty domains
open import PredicateLogic.NonEmptyDomain.TheoremsATP
open import PredicateLogic.NonEmptyDomain.TheoremsI

-- 1.6 Classical predicate logic theorems
open import PredicateLogic.ClassicalATP
open import PredicateLogic.ClassicalI

------------------------------------------------------------------------------
-- 2. Equality

-- 2.1 Definition of equality and some properties about it
open import Common.Relation.Binary.PropositionalEquality

-- 2.2 The equality reasoning
open import Common.Relation.Binary.PreorderReasoning

------------------------------------------------------------------------------
-- 3. Group theory

-- 3.1 The axioms
open import GroupTheory.Base

-- 3.2 Basic properties
open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI

-- 3.3 Commutator properties
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

-- 3.4 Abelian groups
open import GroupTheory.AbelianGroup.PropertiesATP

------------------------------------------------------------------------------
-- 4. Stanovský example (distributive laws on a binary operation)

-- We prove the proposition 2 (task B) of [1]. Let _·_ be a
-- left-associative binary operation, the task B consist in given the
-- left and right distributive axioms

--   ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
--   ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z)

-- to prove the theorem

--   ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
--               (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
--               x ∙ z ∙ (y ∙ u)

-- [1] David Stanovský. Distributive groupoids are symmetrical-by-medial:
--     An elementary proof. Commentations Mathematicae Universitatis
--     Carolinae, 49(4):541–546, 2008.

-- 4.1 The ATPs could not prove the theorem
open import DistributiveLaws.TaskB-ATP

-- 4.2 The interactive and combined proofs
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP

------------------------------------------------------------------------------
-- 5. Peano arithmetic (PA)

-- We write two formalizations of PA. In the axiomatic formalization
-- we use Agda postulates for Peano's axioms. In the inductive
-- formalization, we use Agda data types and primitive recursive
-- functions.

-- 5.1 Axiomatic PA
-- 5.1.1 The axioms
open import PA.Axiomatic.Base

-- 5.1.2 Some properties
open import PA.Axiomatic.PropertiesATP
open import PA.Axiomatic.PropertiesI

open import PA.Axiomatic.Relation.Binary.PropositionalEqualityATP
open import PA.Axiomatic.Relation.Binary.PropositionalEqualityI

-- 5.2. Inductive PA
-- 5.2.1 Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI

------------------------------------------------------------------------------
-- 6. FOTC

-- Formalization of (a version of) Azcel's First Order Theory of Combinators.

-- 6.1 The axioms
open import FOTC.Base

-- 6.2 Booleans

-- 6.2.1 The axioms
open import FOTC.Data.Bool

-- 6.2.2 The inductive predicate
open import FOTC.Data.Bool.Type

-- 6.2.3 Properties
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI

-- 6.3. Natural numbers

-- 6.3.1 The axioms
open import FOTC.Data.Nat

-- 6.3.2 The inductive predicate
open import FOTC.Data.Nat.Type

-- 6.3.3 Properties
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesI

open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI

-- 6.3.4 Divisibility relation
open import FOTC.Data.Nat.Divisibility.By0.Properties
open import FOTC.Data.Nat.Divisibility.By0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.By0.PropertiesI
open import FOTC.Data.Nat.Divisibility.NotBy0.Properties
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 6.3.5 Induction
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI

-- 6.3.6 Inequalites
open import FOTC.Data.Nat.Inequalities.Properties
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI

-- 6.3.7 Unary numbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

-- 6.4 Lists

-- 6.4.1 The axioms
open import FOTC.Data.List

-- 6.4.2 The inductive predicate
open import FOTC.Data.List.Type

-- 6.4.3 Properties
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesI

-- 6.4.4 Well-founded induction
open import FOTC.Data.List.LT-Cons.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Cons.PropertiesI
open import FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Length.PropertiesI

-- 6.4.5 Lists of natural numbers

-- 6.4.5.1 The inductive predicate
open import FOTC.Data.Nat.List.Type

-- 6.4.5.2 Properties
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI

-- 6.5 Coinductive natural numbers

-- 6.5.1 The coinductive predicate
open import FOTC.Data.Conat

-- 6.5.2 Equality on coinductive natural numbers
open import FOTC.Data.Conat.Equality

-- 6.5.3 Properties
open import FOTC.Data.Conat.PropertiesI

-- 6.6 Streams

-- 6.6.1 The coinductive predicate (axioms)
open import FOTC.Data.Stream

-- 6.6.2 Equality on streams
open import FOTC.Data.Stream.Equality
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Data.Stream.Equality.PropertiesI

-- 6.6.3 Properties
open import FOTC.Data.Stream.PropertiesATP
open import FOTC.Data.Stream.PropertiesI

-- 6.7 Programs

-- 6.7.1 The Collatz function: A function without a termination proof
open import FOTC.Program.Collatz.PropertiesATP
open import FOTC.Program.Collatz.PropertiesI

-- 6.7.2 The GCD algorithm: A non-structurally recursive algorithm
open import FOTC.Program.GCD.Partial.ProofSpecificationATP
open import FOTC.Program.GCD.Partial.ProofSpecificationI
open import FOTC.Program.GCD.Total.ProofSpecificationATP
open import FOTC.Program.GCD.Total.ProofSpecificationI

-- 6.7.3 The McCarthy 91 function: A function with nested recursion
open import FOTC.Program.McCarthy91.Properties.MainATP

-- 6.7.4 The mirror function: A function with higher-order recursion
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI

-- 6.7.5 Burstall's sort list algorithm: A structurally recursive algorithm
open import FOTC.Program.SortList.ProofSpecificationATP
open import FOTC.Program.SortList.ProofSpecificationI

-- 6.7.6 The division algorithm: A non-structurally recursive algorithm
open import FOTC.Program.Division.ProofSpecificationATP
open import FOTC.Program.Division.ProofSpecificationI

-- 6.7.7 The map-iterate property: A property using coinduction
open import FOTC.Program.MapIterate.MapIterateATP

-- 6.7.8 The alternating bit protocol: A program using co-inductive types
open import FOTC.Program.ABP.ProofSpecificationATP
open import FOTC.Program.ABP.ProofSpecificationI

-- 6.8 Other modules
-- (These modules are not imported from any module).
open import FOTC.Program.Division.EquationsATP
open import FOTC.Program.GCD.Partial.EquationsATP
open import FOTC.Program.GCD.Total.EquationsATP

------------------------------------------------------------------------------
-- LTC-PCF (Almost a first order theory)

-- Formalization of (a version of) Azcel's Logical Theory of Constructions.
-- N.B. This was the theory shown in our PLPV'09 paper.

-- 7.1. The axioms
open import LTC-PCF.Base

-- 7.2. Natural numberes

-- 7.2.1 The axioms
open import LTC-PCF.Data.Nat

-- 7.2.2 The inductive predicate
open import LTC-PCF.Data.Nat.Type

-- 7.2.3 Properties
open import LTC-PCF.Data.Nat.PropertiesATP
open import LTC-PCF.Data.Nat.PropertiesI

-- 7.2.4 Divisibility relation
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.Properties
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 7.2.5 Induction
open import LTC-PCF.Data.Nat.Induction.NonAcc.LexicographicI
open import LTC-PCF.Data.Nat.Induction.NonAcc.WellFoundedInductionI

-- 7.2.6 Inequalites
open import LTC-PCF.Data.Nat.Inequalities.PropertiesATP
open import LTC-PCF.Data.Nat.Inequalities.PropertiesI

-- 7.2.7 The recursive operator
open import LTC-PCF.Data.Nat.Rec.EquationsATP
open import LTC-PCF.Data.Nat.Rec.EquationsI

-- 7.2.8 A looping combinator
open import LTC-PCF.Loop

-- 7.3 Programs

-- 7.3.1 The division algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.Division.ProofSpecificationATP
open import LTC-PCF.Program.Division.ProofSpecificationI

-- 7.3.2 The GCD algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationATP
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationI

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis, SPASS and Vampire) could not prove some
-- theorems.

open import DistributiveLaws.TaskB-ATP
open import FOTC.Program.ABP.MayorPremiseATP
open import PA.Axiomatic.PropertiesATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see src/Agsy/README.txt

------------------------------------------------------------------------------
-- FOT (First-Order Theories)
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- Code accompanying the paper "Combining Interactive and Automatic
-- Reasoning about Functional Programs" by Ana Bove, Peter Dybjer, and
-- Andrés Sicard-Ramírez.

module README where

------------------------------------------------------------------------------
-- Description

-- Examples of the formalization of first-order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first-order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Prerequisites and use

-- See http://www1.eafit.edu.co/asicard/code/fotc/.

------------------------------------------------------------------------------
-- Conventions

-- The following modules show the formalization of some first-order
-- theories. If the module's name ends in 'I' the module contains
-- interactive proofs, if it ends in 'ATP' the module contains
-- combined proofs, otherwise the module contains definions and/or
-- interactive proofs that are used by the interactive and combined
-- proofs.

------------------------------------------------------------------------------
-- First order theories
------------------------------------------------------------------------------

-- 1. Predicate logic

-- 1.1 Definition of the connectives and quantifiers
open import Common.LogicalConstants
open import PredicateLogic.Constants

-- 1.2 Propositional logic theorems
open import PredicateLogic.Propositional.TheoremsATP
open import PredicateLogic.Propositional.TheoremsI

-- 1.3 Predicate logic theorems
open import PredicateLogic.TheoremsATP
open import PredicateLogic.TheoremsI

-- 1.4 Logical schemas
open import PredicateLogic.SchemasATP

-- 1.5 Non-empty domains
open import PredicateLogic.NonEmptyDomain.TheoremsATP
open import PredicateLogic.NonEmptyDomain.TheoremsI

-- 1.6 Classical predicate logic theorems
open import PredicateLogic.ClassicalATP
open import PredicateLogic.ClassicalI

------------------------------------------------------------------------------
-- 2. Equality

-- 2.1 Definition of equality and some properties about it
open import Common.Relation.Binary.PropositionalEquality

-- 2.2 The equality reasoning
open import Common.Relation.Binary.PreorderReasoning

------------------------------------------------------------------------------
-- 3. Group theory

-- 3.1 The axioms
open import GroupTheory.Base

-- 3.2 Basic properties
open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI

-- 3.3 Commutator properties
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

-- 3.4 Abelian groups
open import GroupTheory.AbelianGroup.PropertiesATP

------------------------------------------------------------------------------
-- 4. Stanovský example (distributive laws on a binary operation)

-- We prove the proposition 2 (task B) of [1]. Let _·_ be a
-- left-associative binary operation, the task B consist in given the
-- left and right distributive axioms

--   ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
--   ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z)

-- to prove the theorem

--   ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
--               (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
--               x ∙ z ∙ (y ∙ u)

-- [1] David Stanovský. Distributive groupoids are symmetrical-by-medial:
--     An elementary proof. Commentations Mathematicae Universitatis
--     Carolinae, 49(4):541–546, 2008.

-- 4.1 The ATPs could not prove the theorem
open import DistributiveLaws.TaskB-ATP

-- 4.2 The interactive and combined proofs
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP

------------------------------------------------------------------------------
-- 5. Peano arithmetic (PA)

-- We write two formalizations of PA. In the axiomatic formalization
-- we use Agda postulates for Peano's axioms. In the inductive
-- formalization, we use Agda data types and primitive recursive
-- functions.

-- 5.1 Axiomatic PA
-- 5.1.1 The axioms
open import PA.Axiomatic.Base

-- 5.1.2 Some properties
open import PA.Axiomatic.PropertiesATP
open import PA.Axiomatic.PropertiesI

open import PA.Axiomatic.Relation.Binary.PropositionalEqualityATP
open import PA.Axiomatic.Relation.Binary.PropositionalEqualityI

-- 5.2. Inductive PA
-- 5.2.1 Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI

------------------------------------------------------------------------------
-- 6. FOTC

-- Formalization of (a version of) Azcel's First Order Theory of Combinators.

-- 6.1 The axioms
open import FOTC.Base

-- 6.2 Booleans

-- 6.2.1 The axioms
open import FOTC.Data.Bool

-- 6.2.2 The inductive predicate
open import FOTC.Data.Bool.Type

-- 6.2.3 Properties
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI

-- 6.3. Natural numbers

-- 6.3.1 The axioms
open import FOTC.Data.Nat

-- 6.3.2 The inductive predicate
open import FOTC.Data.Nat.Type

-- 6.3.3 Properties
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesI

open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI

-- 6.3.4 Divisibility relation
open import FOTC.Data.Nat.Divisibility.By0.Properties
open import FOTC.Data.Nat.Divisibility.By0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.By0.PropertiesI
open import FOTC.Data.Nat.Divisibility.NotBy0.Properties
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 6.3.5 Induction
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI

-- 6.3.6 Inequalites
open import FOTC.Data.Nat.Inequalities.Properties
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI

-- 6.3.7 Unary numbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

-- 6.4 Lists

-- 6.4.1 The axioms
open import FOTC.Data.List

-- 6.4.2 The inductive predicate
open import FOTC.Data.List.Type

-- 6.4.3 Properties
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesI

-- 6.4.4 Well-founded induction
open import FOTC.Data.List.LT-Cons.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Cons.PropertiesI
open import FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Length.PropertiesI

-- 6.4.5 Lists of natural numbers

-- 6.4.5.1 The inductive predicate
open import FOTC.Data.Nat.List.Type

-- 6.4.5.2 Properties
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI

-- 6.5 Coinductive natural numbers

-- 6.5.1 The coinductive predicate
open import FOTC.Data.Conat

-- 6.5.2 Equality on coinductive natural numbers
open import FOTC.Data.Conat.Equality

-- 6.5.3 Properties
open import FOTC.Data.Conat.PropertiesI

-- 6.6 Streams

-- 6.6.1 The coinductive predicate (axioms)
open import FOTC.Data.Stream

-- 6.6.2 Equality on streams
open import FOTC.Data.Stream.Equality
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Data.Stream.Equality.PropertiesI

-- 6.6.3 Properties
open import FOTC.Data.Stream.PropertiesATP
open import FOTC.Data.Stream.PropertiesI

-- 6.7 Programs

-- 6.7.1 The Collatz function: A function without a termination proof
open import FOTC.Program.Collatz.PropertiesATP
open import FOTC.Program.Collatz.PropertiesI

-- 6.7.2 The GCD algorithm: A non-structurally recursive algorithm
open import FOTC.Program.GCD.Partial.ProofSpecificationATP
open import FOTC.Program.GCD.Partial.ProofSpecificationI
open import FOTC.Program.GCD.Total.ProofSpecificationATP
open import FOTC.Program.GCD.Total.ProofSpecificationI

-- 6.7.3 The McCarthy 91 function: A function with nested recursion
open import FOTC.Program.McCarthy91.Properties.MainATP

-- 6.7.4 The mirror function: A function with higher-order recursion
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI

-- 6.7.5 Burstall's sort list algorithm: A structurally recursive algorithm
open import FOTC.Program.SortList.ProofSpecificationATP
open import FOTC.Program.SortList.ProofSpecificationI

-- 6.7.6 The division algorithm: A non-structurally recursive algorithm
open import FOTC.Program.Division.ProofSpecificationATP
open import FOTC.Program.Division.ProofSpecificationI

-- 6.7.7 The map-iterate property: A property using coinduction
open import FOTC.Program.MapIterate.MapIterateATP

-- 6.7.8 The alternating bit protocol: A program using co-inductive types
open import FOTC.Program.ABP.ProofSpecificationATP
open import FOTC.Program.ABP.ProofSpecificationI

-- 6.8 Other modules
-- (These modules are not imported from any module).
open import FOTC.Program.Division.EquationsATP
open import FOTC.Program.GCD.Partial.EquationsATP
open import FOTC.Program.GCD.Total.EquationsATP

------------------------------------------------------------------------------
-- LTC-PCF (Almost a first-order theory)

-- Formalization of (a version of) Azcel's Logical Theory of Constructions.
-- N.B. This was the theory shown in our PLPV'09 paper.

-- 7.1. The axioms
open import LTC-PCF.Base

-- 7.2. Natural numberes

-- 7.2.1 The axioms
open import LTC-PCF.Data.Nat

-- 7.2.2 The inductive predicate
open import LTC-PCF.Data.Nat.Type

-- 7.2.3 Properties
open import LTC-PCF.Data.Nat.PropertiesATP
open import LTC-PCF.Data.Nat.PropertiesI

-- 7.2.4 Divisibility relation
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.Properties
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 7.2.5 Induction
open import LTC-PCF.Data.Nat.Induction.NonAcc.LexicographicI
open import LTC-PCF.Data.Nat.Induction.NonAcc.WellFoundedInductionI

-- 7.2.6 Inequalites
open import LTC-PCF.Data.Nat.Inequalities.PropertiesATP
open import LTC-PCF.Data.Nat.Inequalities.PropertiesI

-- 7.2.7 The recursive operator
open import LTC-PCF.Data.Nat.Rec.EquationsATP
open import LTC-PCF.Data.Nat.Rec.EquationsI

-- 7.2.8 A looping combinator
open import LTC-PCF.Loop

-- 7.3 Programs

-- 7.3.1 The division algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.Division.ProofSpecificationATP
open import LTC-PCF.Program.Division.ProofSpecificationI

-- 7.3.2 The GCD algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationATP
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationI

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis, SPASS and Vampire) could not prove some
-- theorems.

open import DistributiveLaws.TaskB-ATP
open import FOTC.Program.ABP.MayorPremiseATP
open import PA.Axiomatic.PropertiesATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see src/Agsy/README.txt


Fix proof of fundamental theorem

Fix proof of fundamental theorem

I used an assertion on indexes that wasn't true.
Once I fixed the assertion, I made the mistake of actually proving them.
On ANF, this would be simpler.


Added Everything.agda

Added Everything.agda

Ignore-this: 5b827a13f800b7eb7dfb69c1bb56e07b

darcs-hash:20110219141613-3bd4e-e0ea1583b15f4e8809516d5ba59954b5d0a31c86.gz

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

{-# OPTIONS --no-termination-check  #-}

module Draft.Mirror.PropertiesATP where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesATP
open import Draft.Mirror.ListTree.Closures

open import LTC.Data.List
open import LTC.Data.List.PropertiesATP using ( reverse-[x]≡[x] )
open import Draft.Mirror.ListTree.PropertiesATP

open import LTC.Relation.Binary.EqReasoning

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

-- TODO: To remove
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
mirror² (treeT d nilLT) = prf
  where
    postulate prf : mirror · (mirror · node d []) ≡ node d []
    {-# ATP prove prf #-}

mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
  prf (mirror² Tt) (mirror² (treeT d LTts))
  where
    postulate prf : mirror · (mirror · t) ≡ t → -- IH.
                    mirror · (mirror · node d ts) ≡ node d ts → -- IH.
                    mirror · (mirror · node d (t ∷ ts)) ≡ node d (t ∷ ts)
    {-# ATP prove prf reverse-∷ map-ListTree mirror-Tree map-++-commute
                      reverse-++-commute rev-ListTree reverse-[x]≡[x]
                      ++-leftIdentity
    #-}

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

{-# OPTIONS --no-termination-check  #-}

module Draft.Mirror.PropertiesATP where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesATP

open import LTC.Data.List
open import LTC.Data.List.PropertiesATP using ( reverse-[x]≡[x] )
open import Draft.Mirror.ListTree.PropertiesATP

open import LTC.Relation.Binary.EqReasoning

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

-- TODO: To remove
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
mirror² (treeT d nilLT) = prf
  where
    postulate prf : mirror · (mirror · node d []) ≡ node d []
    {-# ATP prove prf #-}

mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
  prf (mirror² Tt) (mirror² (treeT d LTts))
  where
    postulate prf : mirror · (mirror · t) ≡ t → -- IH.
                    mirror · (mirror · node d ts) ≡ node d ts → -- IH.
                    mirror · (mirror · node d (t ∷ ts)) ≡ node d (t ∷ ts)
    {-# ATP prove prf reverse-∷ map-ListTree mirror-Tree map-++ reverse-++ rev-ListTree reverse-[x]≡[x] ++-leftIdentity #-}


Vec: various permutations

Vec: various permutations

module Data.Vec.NP where

open import Data.Vec public
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product hiding (map)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite inject₁-lemma (countᶠ pred (map f xs))
                  | inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite inject₁-lemma (countᶠ pred (xs ++ ys))
                  | inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

module Data.Vec.NP where

open import Data.Vec public
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product hiding (map)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite inject₁-lemma (countᶠ pred (map f xs))
                  | inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite inject₁-lemma (countᶠ pred (xs ++ ys))
                  | inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl


Category/Profunctor

Category/Profunctor

{-# OPTIONS --without-K #-}
-- Based on profunctors 3.1 haskell package
import Level as L
open import Type hiding (★)
open import Function.NP
open import Category.Functor
open import Data.Product

module Category.Profunctor {ℓ} where

record Profunctor {i} (_↝_ : ★ i → ★ i → ★ ℓ) : ★ (ℓ L.⊔ L.suc i) where
  constructor _,_
  field
    lmap : ∀ {A B C} → (A → B) → B ↝ C → A ↝ C
    rmap : ∀ {A B C} → (B → C) → A ↝ B → A ↝ C

  dimap : ∀ {A B C D} → (A → B) → (C → D) → B ↝ C → A ↝ D
  dimap f g = lmap f ∘ rmap g

record Lenticular {i} (_↝_ : ★ i → ★ i → ★ ℓ) : ★ (ℓ L.⊔ L.suc i) where
  constructor mk
  field
    profunctor : Profunctor _↝_
    lenticular : ∀ {A B} → A ↝ B → A ↝ (A × B)
  open Profunctor profunctor public

→Profunctor : Profunctor {ℓ} -→-
→Profunctor = flip _∘′_ , _∘′_

→Lenticular : Lenticular {ℓ} -→-
→Lenticular = mk →Profunctor (λ f x → x , f x)

UpStar : (★ ℓ → ★ ℓ) → ★ ℓ → ★ ℓ → ★ ℓ
UpStar F D C = D → F C

upStarRawFunctor : ∀ {F A} → RawFunctor F → RawFunctor (UpStar F A)
upStarRawFunctor fun = record { _<$>_ = λ k f x → k <$> f x }
  where open RawFunctor fun

upStarProfunctor : ∀ {F} → RawFunctor F → Profunctor (UpStar F)
upStarProfunctor fun = flip _∘′_
                     , RawFunctor._<$>_ (upStarRawFunctor fun)

DownStar : (★ ℓ → ★ ℓ) → ★ ℓ → ★ ℓ → ★ ℓ
DownStar F D C = F D → C

downStarProfunctor : ∀ {F} → RawFunctor F → Profunctor (DownStar F)
downStarProfunctor fun = (λ f g x → g (f <$> x)) , _∘′_
  where open RawFunctor fun

downStarRawFunctor : ∀ {F A} → RawFunctor (DownStar F A)
downStarRawFunctor = record { _<$>_ = _∘′_ }

import Level as L
open import Type hiding (★)
open import Function.NP
open import Category.Functor

module Category.Profunctor {ℓ} where

record Profunctor {i} (_↝_ : ★ i → ★ i → ★ ℓ) : ★ (ℓ L.⊔ L.suc i) where
  constructor _,_
  field
    lmap : ∀ {A B C} → (A → B) → B ↝ C → A ↝ C
    rmap : ∀ {A B C} → (B → C) → A ↝ B → A ↝ C

→Profunctor : Profunctor {ℓ} -→-
→Profunctor = flip _∘′_ , _∘′_

UpStar : (★ ℓ → ★ ℓ) → ★ ℓ → ★ ℓ → ★ ℓ
UpStar F D C = D → F C

upStarRawFunctor : ∀ {F A} → RawFunctor F → RawFunctor (UpStar F A)
upStarRawFunctor fun = record { _<$>_ = λ k f x → k <$> f x }
  where open RawFunctor fun

upStarProfunctor : ∀ {F} → RawFunctor F → Profunctor (UpStar F)
upStarProfunctor fun = flip _∘′_
                     , RawFunctor._<$>_ (upStarRawFunctor fun)

DownStar : (★ ℓ → ★ ℓ) → ★ ℓ → ★ ℓ → ★ ℓ
DownStar F D C = F D → C

downStarProfunctor : ∀ {F} → RawFunctor F → Profunctor (DownStar F)
downStarProfunctor fun = (λ f g x → g (f <$> x)) , _∘′_
  where open RawFunctor fun

downStarRawFunctor : ∀ {F A} → RawFunctor (DownStar F A)
downStarRawFunctor = record { _<$>_ = _∘′_ }


Agda standard library changed the type of _≈_. (The first argument is now an equality).

------------------------------------------------------------------------------
-- The map-iterate property using the standard library
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- From: Nils Anders Danielsson and Thorsten Altenkirch. Mixing
-- Induction and Coinduction. Draft 2009.

module FOT.FOTC.Program.MapIterate.MapIterateSL where

open import Coinduction

open import Data.Stream
open import Relation.Binary.PropositionalEquality

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

map-iterate : ∀ {A} (f : A → A) (x : A) →
              map f (iterate f x) ≈ iterate f (f x)
map-iterate f x = refl ∷ ♯ map-iterate f (f x)

------------------------------------------------------------------------------
-- The map-iterate property using the standard library
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- From: Nils Anders Danielsson and Thorsten Altenkirch. Mixing
-- Induction and Coinduction. Draft 2009.

module FOT.FOTC.Program.MapIterate.MapIterateSL where

open import Coinduction

open import Data.Stream

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

map-iterate : ∀ {A} (f : A → A) (x : A) →
              map f (iterate f x) ≈ iterate f (f x)
map-iterate f x = f x ∷ ♯ map-iterate f (f x)


IDesc model: paranoid alpha-renaming.

IDesc model: paranoid alpha-renaming.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

pair : {i j : Level}{A : Set i}{B : A -> Set j} ->
       (x : A) (y : B x) -> Sigma {i = i}{j = j} A B
pair x y = x , y

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

postulate
  reflFun : {l m : Level}{A : Set l}{B : Set m}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set (suc l)) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set (suc l)} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set (suc l)}(R : I -> IDesc {l = l} I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set (suc l)}(D : IDesc I)(X : I -> Set l) -> desc D X -> IDesc (Sigma I X)
box (var i)     X x        = var (i , x)
box (const _)   X x        = const Unit
box (prod D D') X (d , d') = prod (box D X d) (box D' X d')
box (sigma S T) X (a , b)  = box (T a) X b
box (pi S T)    X f        = pi S (\s -> box (T s) X (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set (suc l)}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = Void
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set (suc l)}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : {l : Level} -> Set (suc l) -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const (Set _)
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))

IDescD : {l : Level}(I : Set (suc l)) -> IDesc {l = suc l} Unit
IDescD I = sigma DescDConst (descDChoice I)

IDescl0 : {l : Level}(I : Set (suc l)) -> Unit -> Set (suc l)
IDescl0 {x} I = IMu {l = suc x} (\_ -> IDescD {l = x} I)

IDescl : {l : Level}(I : Set (suc l)) -> Set (suc l)
IDescl I = IDescl0 I Void

varl : {l : Level}{I : Set (suc l)}(i : I) -> IDescl I
varl {x} i = con (lvar {l = suc x} , i)

constl : {l : Level}{I : Set (suc l)}(X : Set l) -> IDescl I
constl {x} X = con (lconst {l = suc x} , X)

prodl : {l : Level}{I : Set (suc l)}(D D' : IDescl I) -> IDescl I
prodl {x} D D' = con (lprod {l = suc x} , (D , D'))

pil : {l : Level}{I : Set (suc l)}(S : Set l)(T : S -> IDescl I) -> IDescl I
pil {x} S T = con (lpi {l = suc x} , pair {i = suc x}{j = suc x} S (\s -> T (unlift s)))

sigmal : {l : Level}{I : Set (suc l)}(S : Set l)(T : S -> IDescl I) -> IDescl I
sigmal {x} S T = con (lsigma {l = suc x} , pair {i = suc x}{j = suc x} S (\s -> T (unlift s)))

--********************************************
-- From the embedding to the host
--********************************************

cases : {l : Level}
        {I : Set (suc l)}
        (xs : desc (IDescD I) (IMu (λ _ -> IDescD I)))
        (hs : desc (box (IDescD I) (IMu (λ _ -> IDescD I)) xs) (λ _ -> IDesc I)) ->
        IDesc I
cases ( lvar , i ) hs =  var i
cases ( lconst , X ) hs =  const X
cases ( lprod , (D , D') ) ( d , d' ) =  prod d d'
cases ( lpi , ( S , T ) ) hs =  pi S (\s -> hs (lifter s) )
cases ( lsigma , ( S , T ) ) hs = sigma S (\s -> hs (lifter s))

phi : {l : Level}{I : Set (suc l)} -> IDescl I -> IDesc I
phi {x} {I} d = induction (\_ -> IDescD I) (\_ -> IDesc I) (\_ -> cases) Void d

--********************************************
-- From the host to the embedding
--********************************************

psi : {l : Level}{I : Set (suc l)} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set (suc l)} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-psi-phi : {l : Level}(I : Set (suc l)) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> IDescD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
    where P : Sigma Unit (IMu (\ x -> IDescD I)) -> Set (suc x)
          P ( Void , D ) = psi (phi D) == D
          proof-psi-phi-cases : (i : Unit)
                                (xs : desc (IDescD I) (IDescl0 I))
                                (hs : desc (box (IDescD I) (IDescl0 I) xs) P)
                                -> P (i , con xs)
          proof-psi-phi-cases Void (lvar , i) hs = refl
          proof-psi-phi-cases Void (lconst , x) hs = refl
          proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
          proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\T -> con (lpi {l = suc x} , ( S , T ) ))
                                                               (trans (reflFun (\ s -> psi (phi (T (lifter (unlift s)))))
                                                                               (\ s -> psi (phi (T (s))))
                                                                               (\s -> cong (\ s -> psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                       (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))
          proof-psi-phi-cases Void (lsigma , ( S , T )) hs = cong (\T -> con (lsigma {l = suc x} , ( S , T ) ))
                                                                  (trans (reflFun (\ s → psi (phi (T (lifter (unlift s)))))
                                                                                (\ s → psi (phi (T (s))))
                                                                                (\s -> cong (\ s -> psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                         (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

pair : {i j : Level}{A : Set i}{B : A -> Set j} ->
       (x : A) (y : B x) -> Sigma {i = i}{j = j} A B
pair x y = x , y

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

postulate
  reflFun : {l m : Level}{A : Set l}{B : Set m}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set (suc l)) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set (suc l)} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set (suc l)}(R : I -> IDesc {l = l} I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set (suc l)}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const Unit
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set (suc l)}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = Void
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set (suc l)}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : {l : Level} -> Set (suc l) -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const (Set _)
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))

IDescD : {l : Level}(I : Set (suc l)) -> IDesc {l = suc l} Unit
IDescD I = sigma DescDConst (descDChoice I)

IDescl0 : {l : Level}(I : Set (suc l)) -> Unit -> Set (suc l)
IDescl0 {x} I = IMu {l = suc x} (\_ -> IDescD {l = x} I)

IDescl : {l : Level}(I : Set (suc l)) -> Set (suc l)
IDescl I = IDescl0 I Void

varl : {l : Level}{I : Set (suc l)}(i : I) -> IDescl I
varl {x} i = con (lvar {l = suc x} , i)

constl : {l : Level}{I : Set (suc l)}(X : Set l) -> IDescl I
constl {x} X = con (lconst {l = suc x} , X)

prodl : {l : Level}{I : Set (suc l)}(D D' : IDescl I) -> IDescl I
prodl {x} D D' = con (lprod {l = suc x} , (D , D'))

pil : {l : Level}{I : Set (suc l)}(S : Set l)(T : S -> IDescl I) -> IDescl I
pil {x} S T = con (lpi {l = suc x} , pair {i = suc x}{j = suc x} S (\s -> T (unlift s)))

sigmal : {l : Level}{I : Set (suc l)}(S : Set l)(T : S -> IDescl I) -> IDescl I
sigmal {x} S T = con (lsigma {l = suc x} , pair {i = suc x}{j = suc x} S (\s -> T (unlift s)))

--********************************************
-- From the embedding to the host
--********************************************

cases : {l : Level}
        {I : Set (suc l)}
        (xs : desc (IDescD I) (IMu (λ _ -> IDescD I)))
        (hs : desc (box (IDescD I) (IMu (λ _ -> IDescD I)) xs) (λ _ -> IDesc I)) ->
        IDesc I
cases ( lvar , i ) hs =  var i
cases ( lconst , X ) hs =  const X
cases ( lprod , (D , D') ) ( d , d' ) =  prod d d'
cases ( lpi , ( S , T ) ) hs =  pi S (\s -> hs (lifter s) )
cases ( lsigma , ( S , T ) ) hs = sigma S (\s -> hs (lifter s))

phi : {l : Level}{I : Set (suc l)} -> IDescl I -> IDesc I
phi {x} {I} d = induction (\_ -> IDescD I) (\_ -> IDesc I) (\_ -> cases) Void d

--********************************************
-- From the host to the embedding
--********************************************

psi : {l : Level}{I : Set (suc l)} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set (suc l)} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-psi-phi : {l : Level}(I : Set (suc l)) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> IDescD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
    where P : Sigma Unit (IMu (\ x -> IDescD I)) -> Set (suc x)
          P ( Void , D ) = psi (phi D) == D
          proof-psi-phi-cases : (i : Unit)
                                (xs : desc (IDescD I) (IDescl0 I))
                                (hs : desc (box (IDescD I) (IDescl0 I) xs) P)
                                -> P (i , con xs)
          proof-psi-phi-cases Void (lvar , i) hs = refl
          proof-psi-phi-cases Void (lconst , x) hs = refl
          proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
          proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\T -> con (lpi {l = suc x} , ( S , T ) ))
                                                               (trans (reflFun (\ s -> psi (phi (T (lifter (unlift s)))))
                                                                               (\ s -> psi (phi (T (s))))
                                                                               (\s -> cong (\ s -> psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                       (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))
          proof-psi-phi-cases Void (lsigma , ( S , T )) hs = cong (\T -> con (lsigma {l = suc x} , ( S , T ) ))
                                                                  (trans (reflFun (\ s → psi (phi (T (lifter (unlift s)))))
                                                                                (\ s → psi (phi (T (s))))
                                                                                (\s -> cong (\ s -> psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                         (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))


IDescTT model: clean-up.

IDescTT model: clean-up.


restructuring and making headway on #5

restructuring and making headway on #5

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-forms
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- values and indeterminates are disjoint
  vi : ∀{d} → d val → d indet → ⊥
  vi VConst ()
  vi VLam ()

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- todo: these are bad names
  lem2 : ∀{d Δ d'} → d indet → Δ ⊢ d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp () x₁) (ITLam x₂)

  lem3 : ∀{d Δ d'} → d val → Δ ⊢ d →> d' → ⊥
  lem3 VConst ()
  lem3 VLam ()

  lem1 : ∀{d Δ d'} → d final → Δ ⊢ d →> d' → ⊥
  lem1 (FVal x) st = lem3 x st
  lem1 (FIndet x) st = lem2 x st

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (_ , Step (FHFinal x) q _) = lem1 x q
  is IEHole (_ , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (_ , Step (FHFinal x₁) q _) = lem1 x₁ q
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (_ , Step (FHFinal x₁) q _) = lem1 x₁ q
  is (IAp i (FVal x)) (_ , Step (FHAp1 x₁ p) q (FHAp1 x₂ r)) = vs x (_ , Step p q r)
  is (IAp i (FIndet x)) (_ , Step (FHAp1 x₁ p) q (FHAp1 x₂ r)) = is x (_ , Step p q r)
  is (IAp i x) (_ , Step (FHAp2 p) q (FHAp2 r)) = is i (_ , (Step p q r))

  -- final expressions are not errors (not one of the 6 cases for progress)
  fe : ∀{d Δ} → d final → Δ ⊢ d err → ⊥
  fe (FVal x) er = ve x er
  fe (FIndet x) er = ie x er

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  -- cast error cases
  es (ECastError x x₁) (d' , Step (FHFinal x₂) x₃ x₄) = lem1 x₂ x₃
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!!}
  es (ECastError x x₁) (d' , Step (FHCastFinal x₂) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅

  -- ap1 cases
  es (EAp1 er) (d' , Step (FHFinal x) x₁ x₂) = lem1 x x₁
  es (EAp1 er) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = fe x er
  es (EAp1 er) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = es er (_ , Step x x₁ x₂)

  -- ap2 cases
  es (EAp2 er) (d' , Step (FHFinal x) x₁ x₂) = lem1 x x₁
  es (EAp2 er) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = es er (_ , Step x₁ x₂ x₄)
  es (EAp2 er) (d' , Step (FHAp2 x) x₁ x₂) = {!!}

  -- nehole cases
  es (ENEHole er) (d' , Step (FHFinal x) x₁ x₂) = lem1 x x₁
  es (ENEHole er) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole er) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole er) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}

  -- castprop cases
  es (ECastProp er) (d' , Step (FHFinal x) x₁ x₂) = lem1 x x₁
  es (ECastProp er) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp er) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-forms
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- values and indeterminates are disjoint
  vi : ∀{d} → d val → d indet → ⊥
  vi VConst ()
  vi VLam ()

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- todo: these are bad names
  lem2 : ∀{d Δ d'} → d indet → Δ ⊢ d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp () x₁) (ITLam x₂)

  lem3 : ∀{d Δ d'} → d val → Δ ⊢ d →> d' → ⊥
  lem3 VConst ()
  lem3 VLam ()

  lem1 : ∀{d Δ d'} → d final → Δ ⊢ d →> d' → ⊥
  lem1 (FVal x) st = lem3 x st
  lem1 (FIndet x) st = lem2 x st

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (_ , Step (FHFinal x) q _) = lem1 x q
  is IEHole (_ , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (_ , Step (FHFinal x₁) q _) = lem1 x₁ q
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (_ , Step (FHFinal x₁) q _) = lem1 x₁ q
  is (IAp i (FVal x)) (_ , Step (FHAp1 x₁ p) q (FHAp1 x₂ r)) = vs x (_ , Step p q r)
  is (IAp i (FIndet x)) (_ , Step (FHAp1 x₁ p) q (FHAp1 x₂ r)) = is x (_ , Step p q r)
  is (IAp i x) (_ , Step (FHAp2 p) q (FHAp2 r)) = is i (_ , (Step p q r))

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  es (ECastError x x₁) (d' , Step (FHFinal (FVal ())) x₃ x₄)
  es (ECastError x x₁) (d' , Step (FHFinal (FIndet ())) x₃ x₄)
--  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}

  es (ECastError x x₁) (d' , Step (FHCastFinal (FVal x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (ECastError x x₁) (d' , Step (FHCastFinal (FIndet x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (EAp1 e) (d , Step (FHFinal (FVal x)) x₁ q) = vs x (d , Step (FHFinal (FVal x)) x₁ q)
  es (EAp1 e) (d , Step (FHFinal (FIndet x)) x₁ q) = is x (d , Step (FHFinal (FIndet x)) x₁ q)
  es (EAp1 e) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = {!!}
  es (EAp1 e) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = {!!}
  es (EAp2 e) s = {!!}

  --es (ENEHole e) x = {!e!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step FHNEHoleEvaled x₂ x₃) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleInside x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  -- es (ENEHole e) (d' , Step (FHFinal (FVal ())) x₁ x₂)
  -- es (ENEHole e) (d' , Step (FHFinal (FIndet (INEHole x))) () x₂)
  -- es (ENEHole e) (d' , Step FHNEHoleEvaled () x₂)
  -- es (ENEHole e) (_ , Step (FHNEHoleInside x) x₁ (FHNEHoleInside x₂)) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FVal ())))
  -- es (ENEHole (ECastError x x₁)) (_ , Step (FHNEHoleFinal x₂) (ITNEHole x₃) (FHFinal (FIndet (INEHole x₄)))) = {!x₁!}
  -- es (ENEHole (EAp1 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (EAp2 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ENEHole e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ECastProp e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) FHNEHoleEvaled) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FVal x)) (ITCast x₁ x₂ x₃) x₄) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FIndet x)) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}


worked out a few cases with @cyrus- , also removed a premise from one of the subsume rules that we decided we didnt need

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = d' , Δ' , ESAsc2 D
    ... | Inr x = (< _ > d') , Δ' , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = X n , ∅ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = ((< τ2 ==> ⦇⦈ > d1) ∘ d2) , (Δ1 ∪ Δ2) , {!!} -- ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = (d1 ∘ (< {!!} > d2)) , (Δ1 ∪ Δ2) , ESAp2 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = (d1 ∘ d2) , (Δ1 ∪ Δ2) , ESAp3 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume wt x₁) =  _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e' ⦈[ x ]} (ASubsume (SNEHole wt) x₁) with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EANEHole D
    expandability-ana {e = c} (ASubsume SConst x₁) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ())  ESConst x₁
    expandability-ana {e = e ·: x} (ASubsume (SAsc x₁) x₂) = {!!}
    expandability-ana {e = X x} (ASubsume (SVar x₁) x₂) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESVar x₁) x₂
    expandability-ana {e = ·λ x e} (ASubsume () x₁)
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume (SLam x₂ wt) x₃) = _ , _ , _ , EASubsume {!!} {!!} (ESLam x₂ {!!}) x₃
    expandability-ana {e = e1 ∘ e₁} (ASubsume (SAp wt MAHole x₁) x₂) = {!!}
    expandability-ana {e = e1 ∘ e₁} (ASubsume (SAp wt MAArr x₁) x₂) = {!!}
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D'  = {!!}
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = d' , Δ' , ESAsc2 D
    ... | Inr x = (< _ > d') , Δ' , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = X n , ∅ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = ((< τ2 ==> ⦇⦈ > d1) ∘ d2) , (Δ1 ∪ Δ2) , {!!} -- ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = (d1 ∘ (< {!!} > d2)) , (Δ1 ∪ Δ2) , ESAp2 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = (d1 ∘ d2) , (Δ1 ∪ Δ2) , ESAp3 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana (ASubsume wt x₁) with expandability-synth wt
    ... | d' , Δ' , D' = d' , Δ' , _ , EASubsume (λ x → {!!}) (λ x → {!!}) D' x₁ -- what are u and e'?
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D'  = {!!}
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'


FunExt: cleanup

FunExt: cleanup

{-# OPTIONS --without-K #-}
module Function.Extensionality where

-- See Function.Extensionality.Implicit for the extensionality of {x : A} → B x

open import Function.NP
open import Relation.Binary.PropositionalEquality.NP

postulate
    FunExt : Set

module _ {a b}{A : Set a}{B : A → Set b} where
  infix 4 _∼_

  _∼_   : (f₀ f₁ : (x : A) → B x) → Set _
  f₀ ∼ f₁ = (x : A) → f₀ x ≡ f₁ x

  module _ {f₀ f₁ : (x : A) → B x} where
    happly : f₀ ≡ f₁ → f₀ ∼ f₁
    happly p x = ap (λ f₀ → f₀ x) p

    module _ {{fe : FunExt}} where
      postulate
        λ= : (f= : f₀ ∼ f₁) → f₀ ≡ f₁

        happly-λ= : (f= : f₀ ∼ f₁) → happly (λ= f=) ≡ f=

        λ=-happly : (α : f₀ ≡ f₁) → λ= (happly α) ≡ α

        -- This should be derivable if I had a proper proof of λ=
        tr-λ= : ∀ {p x}(P : B x → Set p)(f= : f₀ ∼ f₁)
                → tr (λ f₀ → P (f₀ x)) (λ= f=) ≡ tr P (f= x)

      λ=ⁱ : (f= : ∀ {x} → f₀ x ≡ f₁ x) → f₀ ≡ f₁
      λ=ⁱ f= = λ= λ x → f= {x}

  !-α-λ= : ∀ {f₀ f₁ : (x : A) → B x}{{fe : FunExt}}
             (α : f₀ ≡ f₁) → ! α ≡ λ= (!_ ∘ happly α)
  !-α-λ= refl = ! λ=-happly refl

module _ {a b}{A : Set a}{B : A → Set b}{f₀ f₁ : (x : A) → B x}{{fe : FunExt}} where
  !-λ= : (f= : f₀ ∼ f₁) → ! (λ= f=) ≡ λ= (!_ ∘ f=)
  !-λ= f= = !-α-λ= (λ= f=) ∙ ap λ= (λ= (λ x → ap !_ (happly (happly-λ= f=) x)))
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Function.Extensionality where

open import Function.NP
open import Relation.Binary.PropositionalEquality.NP  -- renaming (subst to tr)

happly : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}
  → f ≡ g → (x : A) → f x ≡ g x
happly p x = ap (λ f → f x) p

postulate
    FunExt : Set
    λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f₀ f₁ : (x : A) → B x}{{fe : FunExt}}
           (f= : ∀ x → f₀ x ≡ f₁ x) → f₀ ≡ f₁

    happly-λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
      (fg : ∀ x → f x ≡ g x) → happly (λ= fg) ≡ fg

    λ=-happly : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
      (α : f ≡ g) → λ= (happly α) ≡ α

    -- This should be derivable if I had a proper proof of λ=
    tr-λ= : ∀ {a b p}{A : Set a}{B : A → Set b}{x}(P : B x → Set p)
              {f g : (x : A) → B x}{{fe : FunExt}}(fg : (x : A) → f x ≡ g x)
            → tr (λ f → P (f x)) (λ= fg) ≡ tr P (fg x)

!-α-λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
  (α : f ≡ g) → ! α ≡ λ= (!_ ∘ happly α)
!-α-λ= refl = ! λ=-happly refl

!-λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
  (fg : ∀ x → f x ≡ g x) → ! (λ= fg) ≡ λ= (!_ ∘ fg)
!-λ= fg = !-α-λ= (λ= fg) ∙ ap λ= (λ= (λ x → ap !_ (happly (happly-λ= fg) x)))

module _ {a b}{A : Set a}{B : A → Set b}{f₀ f₁ : (x : A) → B x}{{fe : FunExt}} where
  λ=ⁱ : (f= : ∀ {x} → f₀ x ≡ f₁ x) → f₀ ≡ f₁
  λ=ⁱ f= = λ= λ x → f= {x}


Move FFI.JS.BigI.FiniteField back to crypto-agda

{-# OPTIONS --without-K #-}
open import Function.NP
open import FFI.JS using (𝟙; Number; Bool; true; false; String; warn-check; check; trace-call; _++_)
open import FFI.JS.BigI
open import Data.List.Base hiding (sum; _++_)
{-
open import Algebra.Raw
open import Algebra.Field
-}

module FFI.JS.BigI.FiniteField (q : BigI) where

abstract
  𝔽 : Set
  𝔽 = BigI

  private
    mod-q : BigI → 𝔽
    mod-q x = mod x q

    check' : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
    -- check' = warn-check
    check' = check

  -- There is two ways to go from BigI to ℤq: check and mod-q
  -- Use check for untrusted input data and mod-q for internal
  -- computation.
  fromBigI : BigI → 𝔽
  fromBigI = -- trace-call "BigI▹ℤq "
    λ x →
      (check' (x <I q)
         (λ _ → "Not below the modulus: q:" ++ toString q ++ " is less than x:" ++ toString x)
         (check' (x ≥I 0I)
            (λ _ → "Should be positive: " ++ toString x ++ " < 0") x))

  check-non-zero : 𝔽 → BigI
  check-non-zero = -- trace-call "check-non-zero "
    λ x → check (x >I 0I) (λ _ → "Should be non zero") x

  repr : 𝔽 → BigI
  repr x = x

  0# 1# : 𝔽
  0# = 0I
  1# = 1I

  1/_ : Op₁ 𝔽
  1/ x = modInv (check-non-zero x) q

  _^_ : Op₂ 𝔽
  x ^ y = modPow (repr x) (repr y) q

_+_ _−_ _*_ _/_ : Op₂ 𝔽

x + y = mod-q (add      (repr x) (repr y))
x − y = mod-q (subtract (repr x) (repr y))
x * y = mod-q (multiply (repr x) (repr y))
x / y = x * 1/ y

0−_ : Op₁ 𝔽
0− x = mod-q (negate (repr x))

_==_ : (x y : 𝔽) → Bool
x == y = equals (repr x) (repr y)

sum prod : List 𝔽 → 𝔽
sum  = foldr _+_ 0#
prod = foldr _*_ 1#

{-
+-mon-ops : Monoid-Ops 𝔽
+-mon-ops = _+_ , 0#

+-grp-ops : Group-Ops 𝔽
+-grp-ops = +-mon-ops , 0−_

*-mon-ops : Monoid-Ops 𝔽
*-mon-ops = _*_ , 1#

*-grp-ops : Group-Ops 𝔽
*-grp-ops = *-mon-ops , 1/_

fld-ops : Field-Ops 𝔽
fld-ops = +-grp-ops , *-grp-ops

postulate
  fld-struct : Field-Struct fld-ops

fld : Field 𝔽
fld = fld-ops , fld-struct
-- -}
-- -}
-- -}
-- -}
-- -}


Update: Field.Solver

Update: Field.Solver

import Algebra.Field as Field
import Algebra.RingSolver as RS

open import Relation.Binary.PropositionalEquality.NP

open import Level
open import Data.Nat as Nat using (ℕ)
open import Data.Fin
open import Data.One
open import Data.Product

open import Function

module Algebra.Field.Solver where

data R-Op : Set where
  [+] [*] [-] : R-Op

data F-Op : Set where
  [+] [*] [-] [/] : F-Op

data Tm (F Op Var : Set) : Set where
  op  : (o : Op) (t₁ t₂ : Tm F Op Var) → Tm F Op Var
  con : F → Tm F Op Var
  var : Var → Tm F Op Var

infixl 6 _:+_ _:-_
infixl 7 _:*_ _:/_
pattern _:+_ x y = op [+] x y
pattern _:*_ x y = op [*] x y
pattern _:-_ x y = op [-] x y
pattern _:/_ x y = op [/] x y

R-include : R-Op → F-Op
R-include [+] = [+]
R-include [*] = [*]
R-include [-] = [-]

module _ {F Op Var : Set}(evalOp : Op → F → F → F)(ρ : Var → F) where
  eval : Tm F Op Var → F
  eval (op o t u) = evalOp o (eval t) (eval u)
  eval (con x) = x
  eval (var x) = ρ x

module _
  {Var : Set}
  {F : Set}
  (𝔽 : Field.Field-Ops F)
  where

  module 𝔽 = Field.Field-Ops 𝔽

  F-Op-eval : F-Op → F → F → F
  F-Op-eval [+] x y = x 𝔽.+ y
  F-Op-eval [*] x y = x 𝔽.* y
  F-Op-eval [-] x y = x 𝔽.− y
  F-Op-eval [/] x y = x 𝔽./ y

  R-Op-eval : R-Op → F → F → F
  R-Op-eval o = F-Op-eval (R-include o)

  evalF : (ρ : Var → F) → Tm F F-Op Var → F
  evalR : (ρ : Var → F) → Tm F R-Op Var → F
  evalF = eval F-Op-eval
  evalR = eval R-Op-eval

  infix 2 _/_:[_,_]
  record Div ρ (t : Tm F F-Op Var) : Set where
    constructor _/_:[_,_]
    field
      N : Tm F R-Op Var
      D : Tm F R-Op Var
      .non-zero-D : evalR ρ D ≢ 𝔽.`0
      .is-correct : evalF ρ t ≡ evalR ρ N 𝔽./ evalR ρ D

  module _ (FS : Field.Field-Struct 𝔽)(ρ : Var → F) where
    open Field.Field-Struct FS

    private
      TmF = Tm F F-Op Var
      TmR = Tm F R-Op Var

      Div' = Div ρ
      ev = evalF ρ

    _+Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :+ u)
    (N / D :[ nD , ok ]) +Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* D₁ :+ N₁ :* D / D :* D₁
       :[ no-zero-divisor nD nD₁ , += ok ok₁ ∙ +-quotient nD nD₁ ]

    _*Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :* u)
    (N / D :[ nD , ok ]) *Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* N₁ / D :* D₁
       :[ no-zero-divisor nD nD₁ , *= ok ok₁ ∙ *-quotient nD nD₁ ]

    _−Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :- u)
    (N / D :[ nD , ok ]) −Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* D₁ :- N₁ :* D / D :* D₁
       :[ no-zero-divisor nD nD₁ , −= ok ok₁ ∙ −-quotient nD nD₁ ]

    _/Div_:[_] : ∀ {t u} → Div' t → Div' u → ev u ≢ `0 → Div' (t :/ u)
    (N / D :[ nD , ok ]) /Div (N₁ / D₁ :[ nD₁ , ok₁ ]) :[ u≢0 ]
      = (N :* D₁) / (D :* N₁)
      :[ no-zero-divisor nD nN₁ , /= ok ok₁ ∙ /-quotient nN₁ nD nD₁ ]
      where .nN₁ : evalR ρ N₁ ≢ `0
            nN₁ p = u≢0 (ok₁ ∙ *= p idp ∙ 0*-zero)

    -- con-Div and var-Div are basically the same but not so convenient to unify
    con-Div : ∀ x → Div' (con x)
    var-Div : ∀ x → Div' (var x)

    con-Div x = con x / con 𝔽.`1 :[ 1≢0 , ! /1-id ]
    var-Div x = var x / con 𝔽.`1 :[ 1≢0 , ! /1-id ]

    Assumptions : TmF → Set
    Assumptions (op [+] t u) = Assumptions t × Assumptions u
    Assumptions (op [*] t u) = Assumptions t × Assumptions u
    Assumptions (op [-] t u) = Assumptions t × Assumptions u
    Assumptions (op [/] t u) = Assumptions t × Assumptions u × ev u ≢ `0
    Assumptions (con x) = Lift 𝟙
    Assumptions (var x) = Lift 𝟙

    to-ring : ∀ (t : TmF) → Assumptions t → Div' t
    to-ring (op [+] t u) (at , au)       = to-ring t at +Div to-ring u au
    to-ring (op [*] t u) (at , au)       = to-ring t at *Div to-ring u au
    to-ring (op [-] t u) (at , au)       = to-ring t at −Div to-ring u au
    to-ring (op [/] t u) (at , au , u≢0) = to-ring t at /Div to-ring u au :[ u≢0 ]
    to-ring (con x) _                    = con-Div x
    to-ring (var x) _                    = var-Div x

-- -}
-- -}
-- -}
-- -}

import Algebra.Field as Field renaming (Field-Ops to RawField ; module Field-Ops to RawField)
import Algebra.RingSolver as RS

open import Relation.Binary.PropositionalEquality.NP

open import Level
open import Data.Nat as Nat using (ℕ ; suc ; zero)
open import Data.Fin
open import Data.One
open import Data.Product

open import Function

module Algebra.Field.Solver
  {f}{F : Set f}
  (𝔽 : Field.RawField F) where

module 𝔽 = Field.RawField 𝔽

data R-Op : Set where
  [+] [*] [-] : R-Op

data F-Op : Set where
  [+] [*] [-] [/] : F-Op

F-Op-eval : F-Op → F → F → F
F-Op-eval [+] x y = x 𝔽.+ y
F-Op-eval [*] x y = x 𝔽.* y
F-Op-eval [-] x y = x 𝔽.− y
F-Op-eval [/] x y = x 𝔽./ y

R-include : R-Op → F-Op
R-include [+] = [+]
R-include [*] = [*]
R-include [-] = [-]

R-Op-eval : R-Op → F → F → F
R-Op-eval op = F-Op-eval (R-include op)

data Tm (Op : Set)(m : ℕ) : Set f where
  op : (o : Op) (t₁ t₂ : Tm Op m) → Tm Op m
  con : F → Tm Op m
  var : Fin m → Tm Op m

infixl 6 _:+_ _:-_
infixl 7 _:*_ _:/_
pattern _:+_ x y = op [+] x y
pattern _:*_ x y = op [*] x y
pattern _:-_ x y = op [-] x y
pattern _:/_ x y = op [/] x y

module _ {m}{Op : Set}(evalOp : Op → F → F → F)(ρ : Fin m → F) where
  eval : Tm Op m → F
  eval (op o tm tm₁) = evalOp o (eval tm) (eval tm₁)
  eval (con x) = x
  eval (var x) = ρ x

infix 2 _/_:[_,_]
record Div {m} ρ (tm : Tm F-Op m) : Set f where
  constructor _/_:[_,_]
  field
    N : Tm R-Op m
    D : Tm R-Op m
    .nonZero-D : eval R-Op-eval ρ D ≢ 𝔽.0ᶠ
    .is-Correct : eval F-Op-eval ρ tm ≡ eval R-Op-eval ρ N 𝔽./ eval R-Op-eval ρ D

module _ (FS : Field.Field-Struct 𝔽) where
  open Field.Field-Struct FS -- {{...}}

  {-
  toRingOp : ∀ {m} → F-Op → Div {m} → Div {m} → Div {m}
  toRingOp [+] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* D' :+ N' :* D  / D :* D'
                                                :[ (λ ρ → noZeroDivisor (P ρ) (P' ρ) ) ]
  toRingOp [*] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* N' / D :* D' :[ (λ ρ → noZeroDivisor (P ρ) (P' ρ)) ]
  toRingOp [-] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* D' :- N' :* D / D :* D'
                                                :[ (λ ρ → noZeroDivisor (P ρ) (P' ρ)) ]
  toRingOp [/] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* D' / N' :* D :[ {!!} ]
  -}

  module _ {m} (ρ : Fin m → F) where
    Assumptions : Tm F-Op m → Set f
    Assumptions (op [+] tm tm₁) = Assumptions tm × Assumptions tm₁
    Assumptions (op [*] tm tm₁) = Assumptions tm × Assumptions tm₁
    Assumptions (op [-] tm tm₁) = Assumptions tm × Assumptions tm₁
    Assumptions (op [/] tm tm₁) = Assumptions tm × Assumptions tm₁ × eval F-Op-eval ρ tm₁ ≢ 0ᶠ
    Assumptions (con x) = Lift 𝟙
    Assumptions (var x) = Lift 𝟙

    toRing : ∀ (tm : Tm F-Op m) → Assumptions tm → Div {m} ρ tm
    toRing (op [+] tm tm₁) (atm , atm₁) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = N :* D₁ :+ N₁ :* D / D :* D₁
                                               :[ noZeroDivisor nD nD₁ , += isC isC₁ ∙ +-quotient nD nD₁ ]
    toRing (op [*] tm tm₁) (atm , atm₁) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = N :* N₁ / D :* D₁
                                               :[ noZeroDivisor nD nD₁ , *= isC isC₁ ∙ *-quotient nD nD₁ ]
    toRing (op [-] tm tm₁) (atm , atm₁) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = N :* D₁ :- N₁ :* D / D :* D₁
                                               :[ noZeroDivisor nD nD₁ , −= isC isC₁ ∙ −-quotient nD nD₁ ]
    toRing (op [/] tm tm₁) (atm , atm₁ , tm₁/=0) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = (N :* D₁) / (D :* N₁)
                                               :[ noZeroDivisor nD nN₁ , /= isC isC₁ ∙ /-quotient nN₁ nD nD₁ ]
      where .nN₁ : eval R-Op-eval ρ N₁ ≢ 0ᶠ
            nN₁ p = tm₁/=0 (isC₁ ∙ *= p refl ∙ 0*-zero)
    toRing (con x) _ = con x / con 𝔽.1ᶠ :[ 0≢1 ∘ !_ , ! (*= refl 1⁻¹≡1 ∙ *1-identity) ]
    toRing (var x) _ = var x / con 𝔽.1ᶠ :[ 0≢1 ∘ !_ , ! (*= refl 1⁻¹≡1 ∙ *1-identity) ]

-- -}
-- -}
-- -}
-- -}