format

format

module PredicateTransformers where

open import Prelude hiding (map; all)
open import Level hiding (lift)

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

{-
https://webspace.science.uu.nl/~swier004/publications/2019-icfp-submission-a.pdf

A predicate transformer semantics for effects

WOUTER SWIERSTRA and TIM BAANEN, Universiteit Utrecht

abstract

reasoning about effectful code harder than pure code

predicate transformer (PT) semantics gives a refinement relation that can be used to
- relate a program to its specification, or
- calculate effectful programs that are correct by construction

------------------------------------------------------------------------------
1 INTRODUCTION

key techniques
- syntax of effectful computations represented as free monads
  - assigning meaning to these monads gives meaning to the syntactic ops each effect provides
- paper shows how to assign PT semantics to computations arising from Kleisli arrows on free monads
  - enables computing the weakest precondition associated with a given postcondition
- using weakest precondition semantics
  - define refinement on computations
  - show how to
    - use this refinement relation to show a program satisfies its specification, or
    - calculate a program from its specification.
- show how programs and specifications may be mixed,
  enabling verified programs to be calculated from their specification one step at a time

------------------------------------------------------------------------------
2 BACKGROUND

--------------------------------------------------
Free monads
-}

module Free where
  -- C          : type of commands
  -- Free C R   : returns an 'a' or issues command c : C
  -- For each c : C, there is a set of responses R c
  -- 2nd arg of Step is continuation : how to proceed after receiving response R c
  data Free {l : Level} (C : Set) (R : C -> Set) (a : Set l) : Set l where
    Pure : a                              -> Free C R a
    Step : (c : C) -> (R c -> Free C R a) -> Free C R a

  -- show that 'Free' is a monad:

  map : forall {l l' C R} -> {a : Set l} -> {b : Set l'}
     -> (a -> b) -> Free C R a
     -> Free C R b
  map f (Pure x)   = Pure (f x)
  map f (Step c k) = Step c (\r -> map f (k r))

  return : forall {l C R} -> {a : Set l}
        -> a -> Free C R a
  return = Pure

  _>>=_ : forall {l l' C R} -> {a : Set l} -> {b : Set l'}
       -> Free C R a -> (a -> Free C R b)
       -> Free C R b
  Pure x   >>= f = f x
  Step c x >>= f = Step c (\r -> x r >>= f)
  infixr 20 _>>=_

  _>>_ : forall {l l' C R} {a : Set l} {b : Set l'}
      -> Free C R a -> Free C R b
      -> Free C R b
  c1 >> c2 = c1 >>= \_ -> c2

  {-
  different effects choose C and R differently, depending on their ops

  --------------------------------------------------
  Weakest precondition semantics

  idea of associating weakest precondition semantics with imperative programs
  dates to Dijkstra’s Guarded Command Language [1975]

  ways to specify behaviour of function f : a -> b
  - reference implementation
  - define a relation R : a -> b -> Set
  - write contracts and test cases
  - PT semantics

  call values of type a -> Set : predicate on type a

  PTs are functions between predicates
  e.g., weakest precondition:
  -}

  -- "maps"
  -- function f : a -> b and
  -- desired postcondition on the function’s output, b -> Set
  -- to weakest precondition a -> Set on function’s input that ensures postcondition satisfied
  --

  -- non-dependent version
  -- note: definition is just reverse function composition
  wp0 : forall
       {a : Set}  -> {b :     Set}
    -> (f :      a  -> b)
    ->            (b   ->  Set)
    -> (a ->  Set)
  wp0 f P = \x -> P   (f x)
  {-
  above wp semantics is sometimes too restrictive
  - no way to specify that output is related to input
  - fix via making f dependent:
  -}

-- dependent version
  wp : forall {l l' l''}
    -> {a : Set l} -> {b : a -> Set l'}
    -> (f : (x : a) -> b x)
    -> ((x : a) -> b x -> Set l'')
    -> (a -> Set l'')
  wp f P = \x -> P x (f x)

  -- shorthand for working with predicates and predicates transformers
  _⊆_ : forall {l'} -> {a : Set}
     -> (a -> Set l')
     -> (a -> Set l')
     -> Set l'
  P ⊆ Q = ∀ x -> P x -> Q x

  -- refinement relation defined between PTs
  _⊑_ : {a : Set} -> {b : a -> Set}
     -> (pt1 pt2 : ((x : a) -> b x -> Set) -> (a -> Set))
     -> Set₁
  pt1 ⊑ pt2 = forall P -> pt1 P ⊆ pt2 P

  ⊑-trans : {a : Set} -> {b : a -> Set} -> {P Q R : ((x : a) -> b x -> Set) -> (a -> Set)}
         -> P ⊑ Q -> Q ⊑ R
         -> P ⊑ R
  ⊑-trans {a} {b} {P} {Q} {R} r1 r2 p x y = r2 p x (r1 p x y)

  ⊑-refl  : {a : Set} -> {b : a -> Set} -> {P : ((x : a) -> b x -> Set) -> (a -> Set)}
         -> P ⊑ P
  ⊑-refl {a} {b} {P} p x H = H

  ⊑-eq    : {a b : Set}
         -> (f g : a -> b) -> wp f ⊑ wp g -> (x : a)
         -> f x == g x
  ⊑-eq f g R x = R (\_ y -> f x == y) x refl

  eq-⊑    : {a b : Set}
         -> (f g : a -> b) -> ((x : a) -> f x == g x)
         -> wp f ⊑ wp g
  eq-⊑ f g eq P x H with f x | g x | eq x
  ... | _ | _ | refl = H

  {-
  use refinement relation
  - to relate PT semantics between programs and specifications
  - to show a program satisfies its specification; or
  - to show that one program is somehow ‘better’ than another,
    where ‘better’ is defined by choice of PT semantics

  in pure setting, this refinement relation is not interesting:
  the refinement relation corresponds to extensional equality between functions:

  lemma follows from the ‘Leibniz rule’ for equality in intensional type theory:
  refinement : ∀ (f g : a -> b) -> (wp f ⊑ wp g) ↔ (∀ x -> f x ≡ g x)

  this paper defines PT semantics for Kleisli arrows of form

      a -> Free C R b

  could use 'wp' to assign semantics to these computations directly,
  but typically not interested in syntactic equality between free monads

  rather want to study semantics of effectful programs they represent

  to define a PT semantics for effects
  define a function with form:

    -- how to lift a predicate on 'a' over effectful computation returning 'a'
    pt : (a -> Set) -> Free C R a -> Set

  'pt' def depends on semantics desired for a particulr free monad

  Crucially, choice of
  - pt and
  - weakest precondition semantics :  wp
  together give a way to assign weakest precondition semantics
  to Kleisli arrows representing effectful computations
  -}

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

module Maybe where
  open import Data.Nat public
    using
      (_+_; _>_; _*_
      )
    renaming
      ( ℕ to Nat
      ; zero to Zero
      ; suc to Succ
      )
  open import Data.Nat.DivMod using (_div_)
  open import Data.Nat.Properties using (*-zeroʳ)
  open Free

  {-
  ------------------------------------------------------------------------------
  3 PARTIALITY

  Partial computations : i.e., 'Maybe'

  make choices for commands C and responses R
  -}

  data C : Set where
    Abort : C -- no continuation

  R : C -> Set
  R Abort = ⊥ -- since C has no continuation, valid responses is empty

  Partial : Set -> Set
  Partial = Free C R

  -- smart constructor for failure
  abort : forall {a} -> Partial a
  abort = Step Abort (\())

  {-
  computation of type Partial a will either
  - return a value of type a or
  - fail, issuing abort command

  Note that responses to Abort command are empty;
  abort smart constructor abort uses this to discharge the continuation
  in the second argument of the Step constructor

  --------------------------------------------------
  Example: division

  expression language, closed under division and natural numbers:
  -}

  data Expr : Set where
    Val : Nat  -> Expr
    Div : Expr -> Expr -> Expr

  exv : Expr
  exv = Val 3
  exd : Expr
  exd = Div (Val 3) (Val 3)

  -- semantics specified using inductively defined RELATION:
  -- def rules out erroneous results by requiring the divisor evaluates to non-zero
  data _⇓_ : Expr -> Nat -> Set where
    ⇓Base : forall {x}
         -> Val x ⇓ x
    ⇓Step : forall {l r v1 v2}
         ->     l   ⇓  v1
         ->       r ⇓         (Succ v2)
         -> Div l r ⇓ (v1 div (Succ v2))

  exb : Val 3 ⇓ 3
  exb = ⇓Base

  exs : Div (Val 3) (Val 3) ⇓ 1
  exs = ⇓Step ⇓Base ⇓Base

  -- alternatively, semantics specified by an INTERPRETER
  -- evaluate Expr via monadic INTERPRETER, using Partial to handle division-by-zero

  -- define operation used by ⟦_⟧ interpreter
  _÷_ : Nat -> Nat -> Partial Nat
  n ÷ Zero     = abort
  n ÷ (Succ k) = return (n div (Succ k))

  ⟦_⟧ : Expr -> Partial Nat
  ⟦ Val x ⟧     =  return x
  ⟦ Div e1 e2 ⟧ =  ⟦ e1 ⟧ >>= \v1 ->
                   ⟦ e2 ⟧ >>= \v2 ->
                   v1 ÷ v2

  evv   : Free C R Nat
  evv   = ⟦ Val 3 ⟧
  evv'  : evv ≡ Pure 3
  evv'  = refl

  evd   : Free C R Nat
  evd   = ⟦ Div (Val 3) (Val 3) ⟧
  evd'  : evd ≡ Pure 1
  evd'  = refl

  evd0  : Free C R Nat
  evd0  = ⟦ Div (Val 3) (Val 0) ⟧
  evd0' : evd0 ≡ Step Abort (λ ())
  evd0' = refl

  {-
  How to relate two definitions:
  - std lib 'div' requires implicit proof that divisor is non-zero
    - ⇓ relation generates via pattern matching
    - _÷_ does explicit check
  - interpreter uses _÷_
    - fails explicitly with abort when divisor is zero

  Assign a weakest precondition semantics to Kleisli arrows of the form

      a -> Partial b
  -}

  mustPT : forall {a : Set} -> {b : a -> Set}
        -> (P : (x : a) -> b x -> Set)
        ->      (x : a)
        ->                  Partial (b x)
        -> Set
  mustPT P _ (Pure y)       = P _ y
  mustPT P _ (Step Abort _) = ⊥

  wpPartial : {a : Set} -> {b : a -> Set}
           -> (f : (x : a) -> Partial (b x))
           -> (P : (x : a) ->          b x -> Set)
           -> (a -> Set)
  wpPartial f P = wp f (mustPT P)

  {-
  To call 'wp', must show how to transform
  -      predicate                  P :         b -> Set
  - to a predicate on partial results : Partial b -> Set
  Done via proposition 'mustPT P c'
  - holds when computation c of type Partial b successfully returns a 'b' that satisfies P

  particular PT semantics of partial computations determined by def mustPT
  here: rule out failure entirely
  - so case Abort returns empty type

  Given this PT semantics for Kleisli arrows in general,
  can now study semantics of above monadic interpreter
  via passing
  - interpreter: ⟦_⟧
  - desired postcondition : _⇓_
  as arguments to wpPartial:
  -}

  exwpp  : Expr -> Set
  exwpp  = wpPartial ⟦_⟧ _⇓_
  exwpp' : wpPartial ⟦_⟧ _⇓_ ≡ λ expr -> mustPT _⇓_ expr ⟦ expr ⟧
  exwpp' = refl

  wppv1  : wpPartial ⟦_⟧ _⇓_ (Val 1)
  wppv1  = ⇓Base
  wppd   : wpPartial ⟦_⟧ _⇓_ (Div (Val 1) (Val 1))
  wppd   = ⇓Step ⇓Base ⇓Base

  xxx    : mustPT _⇓_ (Div (Val 3) (Val 3)) (Pure 3 >>= (λ v1 -> Pure 3 >>= _÷_ v1))
  xxx    = ⇓Step {Val 3} {Val 3} {3} {2} ⇓Base ⇓Base

  xxx'   : mustPT _⇓_ (Div (Val 3) (Val 3)) (3 ÷ 3)
  xxx'   = ⇓Step {Val 3} {Val 3} {3} {2} ⇓Base ⇓Base

  {-
  resulting in a predicate on expressions

  for all expressions satisfying this predicate,
  the monadic interpreter and the relational specification, _⇓_,
  must agree on the result of evaluation

  What does this say about correctness of interpreter?
  To understand the predicate better, consider defining this predicate on expressions:
  -}

  SafeDiv : Expr -> Set
  SafeDiv (Val x)     = ⊤
  SafeDiv (Div e1 e2) = (e2 ⇓ Zero -> ⊥) ∧ SafeDiv e1 ∧ SafeDiv e2

  exsdv : SafeDiv (Val 3) ≡ ⊤
  exsdv = refl
  exsdd : SafeDiv (Div (Val 3) (Val 3)) ≡ Pair ((x : Val    3 ⇓ Zero) -> ⊥) (Pair (⊤' zero) (⊤' zero))
  exsdd = refl

  exsdx : SafeDiv (Div (Val 3) (Val 0)) ≡ Pair ((x : Val Zero ⇓ Zero) -> ⊥) (Pair (⊤' zero) (⊤' zero))
  exsdx = refl

  {-
  Expect : any expr e for which SafeDiv e holds
  can be evaluated without division-by-zero

  can prove SafeDiv is sufficient condition for two notions of evaluation to coincide:

  -- lemma relates the two semantics
  -- expressed as a relation and an evaluator
  -- for those expressions that satisfy the SafeDiv property
  -}

  correct : SafeDiv ⊆ wpPartial ⟦_⟧ _⇓_
  correct (Val x) h = ⇓Base
  correct (Div e1 e2) (e2nz , (sde1 , sde2)) with ⟦ e1 ⟧ | ⟦ e2 ⟧ | correct e1 sde1 | correct e2 sde2
  correct (Div e1 e2) (e2nz , (sde1 , sde2)) | Pure v1      | Pure Zero         | e1⇓v1 | e2⇓Z   = magic (e2nz e2⇓Z)
  correct (Div e1 e2) (e2nz , (sde1 , sde2)) | Pure v1      | Pure (Succ v2)    | e1⇓v1 | e2⇓Sv2 = ⇓Step e1⇓v1 e2⇓Sv2
  correct (Div e1 e2) (e2nz , (sde1 , sde2)) | Pure v1      | Step Abort ⊥→FCRN | e1⇓v1 | ()
  correct (Div e1 e2) (e2nz , (sde1 , sde2)) | Step Abort _ | _                 | ()    | _

  {-
  Instead of manually defining SafeDiv,
  define more general predicate characterising the domain of a partial function:
  -}

  dom : {a : Set} -> {b : a -> Set}
     -> ((x : a)
     -> Partial (b x))
     -> (a -> Set)
  dom f = wpPartial f (\_ _ -> ⊤)

  -- can show that the two semantics agree precisely on the domain of the interpreter:

  sound     : dom       ⟦_⟧       ⊆   wpPartial ⟦_⟧ _⇓_

  complete  : wpPartial ⟦_⟧ _⇓_   ⊆   dom       ⟦_⟧

  -- both proofs proceed by induction on the argument expression

  sound (Val x) h = ⇓Base
  sound (Div e1 e2) h with ⟦ e1 ⟧ | ⟦ e2 ⟧ | sound e1 | sound e2
  sound (Div e1 e2) () | Pure v1      | Pure Zero      | ih1 | ih2
  sound (Div e1 e2) h  | Pure v1      | Pure (Succ v2) | ih1 | ih2 = ⇓Step (ih1 tt) (ih2 tt)
  sound (Div e1 e2) () | Pure x       | Step Abort x₁  | ih1 | ih2
  sound (Div e1 e2) () | Step Abort x | v2             | ih1 | ih2

  inDom : {v : Nat} -> (e : Expr) -> ⟦ e ⟧ == Pure v -> dom ⟦_⟧ e
  inDom (Val x) h = tt
  inDom (Div e1 e2) h with ⟦ e1 ⟧ | ⟦ e2 ⟧
  inDom (Div e1 e2) () | Pure v1      | Pure Zero
  inDom (Div e1 e2) h  | Pure v1      | Pure (Succ v2) = tt
  inDom (Div e1 e2) () | Pure _       | Step Abort _
  inDom (Div e1 e2) () | Step Abort _ | _

  aux : (e : Expr) (v : Nat) -> ⟦ e ⟧ ≡ Pure v -> e ⇓ v
  aux e v eq with sound e (inDom e eq)
  ... | H rewrite eq = H

  wpPartial1 : {e1 e2 : Expr} -> wpPartial ⟦_⟧ _⇓_ (Div e1 e2) -> wpPartial ⟦_⟧ _⇓_ e1
  wpPartial1 {e1} {e2} h with ⟦ e1 ⟧ | inspect ⟦_⟧ e1 | ⟦ e2 ⟧
  wpPartial1 {e1} {e2} () | Pure x       | eq         | Pure Zero
  wpPartial1 {e1} {e2} h  | Pure x       | [[[ eq ]]] | Pure (Succ y) = aux e1 x eq
  wpPartial1 {e1} {e2} () | Pure x       | eq         | Step Abort x₁
  wpPartial1 {e1} {e2} () | Step Abort x | eq         | ve2

  wpPartial2 : {e1 e2 : Expr} -> wpPartial ⟦_⟧ _⇓_ (Div e1 e2) -> wpPartial ⟦_⟧ _⇓_ e2
  wpPartial2 {e1} {e2} h with ⟦ e1 ⟧ | inspect ⟦_⟧ e1 | ⟦ e2 ⟧ | inspect ⟦_⟧ e2
  wpPartial2 {e1} {e2} h  | Pure x       | [[[ eqx ]]] | Pure y        | [[[ eqy ]]] = aux e2 y eqy
  wpPartial2 {e1} {e2} () | Pure x       | [[[ eq ]]]  | Step Abort x₁ | eq2
  wpPartial2 {_}  {_}  () | Step Abort x | eq1         | se2           | eq2

  complete (Val x) h = tt
  complete (Div e1 e2) h
    with ⟦ e1 ⟧ | inspect ⟦_⟧ e1 | ⟦ e2 ⟧ | inspect ⟦_⟧ e2
      | complete e1 (wpPartial1 {e1} {e2} h)
      | complete e2 (wpPartial2 {e1} {e2} h)
  complete (Div e1 e2) h | Pure x       | [[[ eqx ]]] | Pure Zero     | [[[ eqy ]]] | p1 | p2
    rewrite eqx | eqy = magic h
  complete (Div e1 e2) h | Pure x       | [[[ eqx ]]] | Pure (Succ y) | [[[ eqy ]]] | p1 | p2 = tt
  complete (Div e1 e2) h | Pure x       | eq1         | Step Abort x₁ | eq2         | p1 | ()
  complete (Div e1 e2) h | Step Abort x | eq1         | se2           | eq2         | () | p2

  {-
  --------------------------------------------------
  Refinement

  weakest precondition semantics on partial computations give rise
  to a refinement relation on Kleisli arrows of the form a -> Partial b

  can characterise this relation by proving:

  refinement : (f g : a -> Maybe b)
             -> (wpPartial f ⊑ wpPartial g) ↔ (∀ x -> (f x ≡ g x) ∨ (f x ≡ Nothing))

  use refinement to relate Kleisli morphisms,
  and to relate a program to a specification given by a pre- and postcondition

  --------------------------------------------------
  Example: Add (interpreter for stack machine)

  add top two elements; can fail fail if stack has too few elements

  below shows how to prove the definition meets its specification

  Define specification in terms of a pre/post condition.
  -}
  -- specification of a function of type (x : a) -> b x consists of:
  record Spec {l : Level} (a : Set) (b : a -> Set) : Set (suc l) where
    constructor [[_,_]]
    field
      pre   : a -> Set l              -- precondition on 'a'
      post  : (x : a) -> b x -> Set l -- postcondition relating inputs that satisfy this precondition
                                      -- and the corresponding outputs

  {-
  [ P , Q ] : specification consisting of precondition P and postcondition Q

  for non-dependent examples (e.g., type b does not depend on x : a)
  -}

  SpecK : {l : Level} -> Set -> Set -> Set (suc l)
  SpecK a b = Spec a (K b) -- K is constant function

  -- specification for addition function : describes the desired postcondition
  data Add : List Nat -> List Nat -> Set where
    AddStep : {x1 x2 : Nat} -> {xs : List Nat}
           -> Add (x1 :: x2 :: xs) ((x1 + x2) :: xs)

  addSpec : SpecK (List Nat) (List Nat)
  addSpec = [[ (\xs -> length xs > 1) , Add ]]

  {-
  How to relate this specification to an implementation?
  Note: 'wpPartial' assigns predicate transformer semantics to functions
  - but do not yet have a corresponding predicate transform semantics for specifications.
  wpSpec function does that:
  -}

  -- Given a specification, Spec a b
  -- computes the weakest precondition that satisfies an arbitrary postcondition P
  -- i.e., the spec’s precondition should hold and its postcondition must imply P.
  wpSpec : forall {l a} -> {b : a -> Set}
        -> Spec {l} a b
        -> (P : (x : a) -> b x -> Set l)
        -> (a -> Set l)
  wpSpec [[ pre , post ]] P = \x -> (pre x) ∧ (post x ⊆ P x)

  -- Can now formulate program

  pop : forall {a} -> List a -> Partial (a × List a)
  pop Nil       = abort
  pop (x :: xs) = return (x , xs)

  add : List Nat -> Partial (List Nat)
  add xs =
    pop xs >>= \{(x1 , xs) ->
    pop xs >>= \{(x2 , xs) ->
    return ((x1 + x2) :: xs)}}

  -- that refines the specification given by addSpec:
  correctnessAdd : wpSpec addSpec ⊑ wpPartial add
  correctnessAdd P Nil (() , _)
  correctnessAdd P (x :: Nil) (Data.Nat.s≤s () , _)
  correctnessAdd P (x :: y :: xs) (_ , H) = H (x + y :: xs) AddStep

  {-
  This example illustrates how to use the refinement relation
  - to relate a specification
    - given in terms of a pre- and postcondition,
  - to its implementation.

  Compared to the refinement calculus
  - have not yet described how to mix code and specifications (see Section 7)

  --------------------------------------------------
  Alternative semantics
  -}

  product : List Nat -> Nat
  product = foldr _*_ 1

  fastProduct : List Nat -> Partial Nat
  fastProduct Nil          = return 1
  fastProduct (Zero :: xs) = abort
  fastProduct (k :: xs)    = map (_*_ k) (fastProduct xs)

  defaultHandler : forall {a} -> a -> Partial a -> a
  defaultHandler _ (Pure x)       = x
  defaultHandler d (Step Abort _) = d

  wpDefault : forall {a b : Set}
           -> (d : b)
           -> (f : a -> Partial b)
           -> (P : a -> b -> Set)
           -> (a -> Set)
  wpDefault {a} {b} d f P = wp f defaultPT
    where
    defaultPT : (x : a) -> Partial b -> Set
    defaultPT x (Pure y)       = P x y
    defaultPT x (Step Abort _) = P x d

  soundness : forall {a b}
           -> (P : a -> b -> Set)
           -> (d : b)
           -> (c : a -> Partial b)
           -> forall x
           -> wpDefault d c P x
           -> P x (defaultHandler d (c x))
  soundness P d c x H with c x
  soundness P d c x H | Pure y       = H
  soundness P d c x H | Step Abort _ = H

  correctnessProduct : wp product ⊑ wpDefault 0 fastProduct
  correctnessProduct   P Nil H = H
  correctnessProduct   P (Zero :: xs) H = H
  correctnessProduct   P (Succ x :: xs) H
    with fastProduct xs | correctnessProduct (\xs v -> P (Succ x :: xs) _) xs H
  correctnessProduct   P (Succ x :: xs) H | Pure v       | IH                   = IH
  correctnessProduct   P (Succ x :: xs) H | Step Abort _ | IH rewrite *-zeroʳ x = IH

module State (s : Set) where
  open Free
  open Maybe using (SpecK; Spec; [[_,_]]; wpSpec)
  data C : Set where
    Get : C
    Put : s -> C

  R : C -> Set
  R Get     = s
  R (Put _) = ⊤

  State : forall {l} -> Set l -> Set l
  State = Free C R
  get : State s
  get = Step Get return

  put : s -> State ⊤
  put s = Step (Put s) (\_ -> return tt)

  run : {a : Set} -> State a -> s -> a × s
  run (Pure x)         s = (x , s)
  run (Step Get k)     s = run (k s) s
  run (Step (Put s) k) _ = run (k tt) s

  statePT : forall {l l'} -> {b : Set l} -> (b × s -> Set l') -> State b -> (s -> Set l')
  statePT P (Pure x)         = \s ->         P (x , s)
  statePT P (Step  Get    k) = \s -> statePT P (k  s) s
  statePT P (Step (Put s) k) = \_ -> statePT P (k tt) s

  statePT' : forall {l l'} -> {b : Set l}
          -> (s -> b × s -> Set l')
          -> State b
          -> (s -> Set l')
  statePT' P c i = statePT (P i) c i

  wpState : forall {l l' l''} -> {a : Set l} -> {b : Set l'}
         -> (a -> State b)
         -> (P : a × s -> b × s -> Set l'')
         -> (a × s -> Set l'')
  wpState f P (x , i) = wp f ((const \c -> statePT' (\j -> P (x , j)) c i)) x

  soundness : forall {a b : Set}
           -> (P : a × s -> b × s -> Set)
           -> (f : a -> State b)
           -> forall i x
           -> wpState f P (x , i)
           -> P (x , i) (run (f x) i)
  soundness {a} {b} P c i x H = lemma i (c x) H
    where
    lemma : (st : s) -> (statec : State b) -> (statePT (P (x , i)) statec st) -> P (x , i) (run statec st)
    lemma i (Pure y)         H = H
    lemma i (Step Get     k) H = lemma i (k  i) H
    lemma i (Step (Put s) k) H = lemma s (k tt) H

module Relabel where
  open Free
  open Maybe using (Spec; SpecK; [[_,_]]; wpSpec)
  open import Data.Nat public
    using
      (_+_; _>_; _*_
      )
    renaming
      ( ℕ to Nat
      ; zero to Zero
      ; suc to Succ
      )

  module StateNat = State Nat
  open StateNat

  data Tree (a : Set) : Set where
    Leaf  :      a           -> Tree a
    Node  : Tree a -> Tree a -> Tree a

  flatten : ∀ {a} -> Tree a -> List a
  flatten (Leaf x)   = [ x ]
  flatten (Node l r) = flatten l ++ flatten r

  size : ∀ {a} -> Tree a -> Nat
  size (Leaf x)   = 1
  size (Node l r) = size l + size r

  seq : Nat -> Nat -> List Nat
  seq i Zero     = Nil
  seq i (Succ n) = Cons i (seq (Succ i) n)

  relabelSpec : forall {a} -> SpecK (Tree a × Nat) (Tree Nat × Nat)
  relabelSpec = [[ K ⊤ , relabelPost ]]
    where
      relabelPost : forall {a} -> Tree a × Nat -> Tree Nat × Nat -> Set
      relabelPost (t , s) (t' , s') = (flatten t' == (seq (s) (size t))) ∧ (s + size t == s')

  fresh : State Nat
  fresh =  get >>= \n ->
           put (Succ n) >>
           return n

  relabel : forall {a} -> Tree a -> State (Tree Nat)
  relabel (Leaf x)   = map Leaf fresh
  relabel (Node l r) =
    relabel l >>= \l' ->
    relabel r >>= \r' ->
    return (Node l' r')

  correctnessRelabel : forall {a : Set} -> wpSpec ( relabelSpec {a}) ⊑ wpState relabel

  compositionality : forall {a b : Set} -> (c : State a) (f : a -> State b) ->
    ∀ i P -> statePT P (c >>= f) i == statePT (wpState f (const P)) c i

  compositionality (Pure x) f i P = refl
  compositionality (Step Get k) f i P = compositionality (k i) f i P
  compositionality (Step (Put x) k) f i P = compositionality (k tt) f x P

  correctnessRelabel = step2
    where
    open NaturalLemmas
    --   Simplify proofs of refining a specification,
    --   by first proving one side of the bind, then the second.
    --   This is essentially the first law of consequence,
    --   specialized to the effects of State and Spec.
    prove-bind : ∀ {a b} (mx : State a) (f : a -> State b) P i ->
      statePT (wpState f \_ -> P) mx i -> statePT P (mx >>= f) i
    prove-bind mx f P i x = coerce {zero} (sym (compositionality mx f i P)) x

    prove-bind-spec : ∀ {a b} (mx : State a) (f : a -> State b) spec ->
      ∀ P i -> (∀ Q -> Spec.pre spec i × (Spec.post spec i ⊆ Q) -> statePT Q mx i) ->
      Spec.pre spec i × (Spec.post spec i ⊆ wpState f (\_ -> P)) ->
      statePT P (mx >>= f) i
    prove-bind-spec mx f spec P i Hmx Hf = prove-bind mx f P i (Hmx (wpState f (\_ -> P)) Hf)

    --   Partially apply a specification.
    applySpec : ∀ {a b s} -> SpecK {zero} (a × s) (b × s) -> a -> SpecK s (b × s)
    applySpec [[ pre , post ]] x = [[ (\s -> pre (x , s)) , (\s -> post (x , s)) ]]

    --   Ingredients for proving the postcondition holds.
    --   By abstracting over the origin of the numbers,
    --   we can do induction on them nicely.
    append-seq : ∀ a b c -> seq a b ++ seq (a + b) c ≡ seq a (b + c)
    append-seq a Zero c = cong (\a' -> seq a' c) (sym (plus-zero a))
    append-seq a (Succ b) c = cong (Cons a) (trans
      (cong (\a+b -> seq (Succ a) b ++ seq a+b c) (+-succ a b))
      (append-seq (Succ a) b c))

    postcondition : ∀ s s' s'' sl fl sr fr ->
      Pair (fl ≡ seq s sl) (s + sl ≡ s') ->
      Pair (fr ≡ seq s' sr) (s' + sr ≡ s'') ->
      Pair (fl ++ fr ≡ seq s (sl + sr)) (s + (sl + sr) ≡ s'')
    postcondition s .(s + sl) .(s + sl + sr) sl .(seq s sl) sr .(seq (s + sl) sr)
      (refl , refl) (refl , refl) = append-seq s sl sr , +-assoc s sl sr

    --   We have to rewrite the formulation of step2 slightly to make it acceptable for the termination checker.

    step2' : ∀ {a} P (t : Tree a) s -> wpSpec relabelSpec P (t , s) -> statePT (P (t , s)) (relabel t) s
    step2' P (Leaf x) s (fst , snd) = snd (Leaf s , Succ s) (refl , plus-one s)
    step2' P (Node l r) s (fst , snd) = prove-bind-spec (relabel l) _ (applySpec relabelSpec l) _ _
      (\Q -> step2' (\_ -> Q) l s)
      (tt , \l',s' postL -> let l' = Pair.fst l',s' ; s' = Pair.snd l',s'
        in prove-bind-spec (relabel r) _ (applySpec relabelSpec r) _ _
          (\Q -> step2' (\_ -> Q) r s')
          (tt , \r',s'' postR -> let r' = Pair.fst r',s'' ; s'' = Pair.snd r',s''
            in snd (Node l' r' , s'') (postcondition s s' s'' (size l) (flatten l') (size r) (flatten r') postL postR)))
    step2 : wpSpec relabelSpec ⊑ wpState relabel
    step2 P (t , s) (fst , snd) = step2' P t s (fst , snd)

module Compositionality
  (C : Set) (R : C -> Set) (ptalgebra : (c : C) -> (R c -> Set) -> Set)
  where
  open Free
  open Maybe using (wpSpec; [[_,_]])

  postulate
    ext : {l l' : Level} {a : Set l} {b : Set l'} -> {f g : a -> b} ->
      ((x : a) -> f x ≡ g x) -> f ≡ g

  pt : {a : Set} -> Free C R a -> (a -> Set) -> Set
  pt (Pure   x) P = P x
  pt (Step c x) P = ptalgebra c (\r -> pt (x r) P)

  wpCR : {a : Set} {b : a -> Set} ->
      ((x : a) -> Free C R (b x)) -> ((x : a) -> b x -> Set) -> (a -> Set)
  wpCR f P x = pt (f x) (P x)

  compositionality : forall {a b : Set} -> (c : Free C R a) (f : a -> Free C R b) ->
    ∀ P -> pt (c >>= f) P ≡ pt c (wpCR f (const P))
  compositionality (Pure x) f P = refl
  compositionality (Step c x) f P =
    cong (\h -> ptalgebra c h) (ext (\r -> compositionality (x r) f P))

  _>=>_ : forall {l l' l''} -> {a : Set l} -> {b : Set l'} -> {c : Set l''} -> forall {C R} -> (a -> Free C R b) -> (b -> Free C R c) -> a -> Free C R c
  f >=> g = \x -> f x >>= g

  compositionality-left : forall {a b c : Set} -> (f1 f2 : a -> Free C R b) (g : b -> Free C R c) ->
    wpCR f1 ⊑ wpCR f2 ->
    wpCR (f1 >=> g) ⊑ wpCR (f2 >=> g)
  compositionality-left mx my f H P x y
    rewrite compositionality (mx x) f (P x)
    | compositionality (my x) f (P x) =
     H (\x y -> pt (f y) (P x)) x y

  compositionality-right : forall {a b c} -> (f : a -> Free C R b) (g1 g2 : b -> Free C R c) ->
    wpCR g1 ⊑ wpCR g2 ->
    wpCR (f >=> g1) ⊑ wpCR (f >=> g2)
  postulate
    monotonicity : forall {a} -> {P Q : a -> Set} -> P ⊆ Q -> (c : Free C R a) -> pt c P -> pt c Q
  compositionality-right mx f g H P x wp1
    rewrite compositionality (mx x) f (P x)
    | compositionality (mx x) g (P x) = monotonicity (H _) (mx x) wp1

  weakenPre          : {a : Set} -> {b : a -> Set} -> {P P' : a -> Set} -> {Q : (x : a) -> b x -> Set} -> (P ⊆ P') -> (wpSpec [[ P , Q ]] ⊑ wpSpec [[ P' , Q ]])

  strengthenPost     : {a : Set} -> {b : a -> Set} -> {P : a -> Set} -> {Q Q' : (x : a) -> b x -> Set} -> (forall (x : a) -> Q' x ⊆ Q x) -> (wpSpec [[ P , Q ]] ⊑ wpSpec [[ P , Q' ]])

  weakenPre H1 p H2 (pre , post) = (H1 H2 pre , post)

  strengthenPost H1 p H2 (pre , post) = (pre , \x y -> post x (H1 _ x y))

module Laws (s : Set) where
  open Free
  open Maybe using (SpecK; Spec; [[_,_]]; wpSpec)
  module StateS = State s
  open StateS

  postulate
    a : Set
    k0 : State a
    k1 : s -> State a
    k2 : s -> s -> State a
    x y : s

  _≃_ : forall {b : Set} -> State b -> State b -> Set₁
  t1 ≃ t2 = (wpState' t1 ⊑ wpState' t2) ∧ (wpState' t2 ⊑ wpState' t1)
    where
    wpState' : forall {b} -> State b -> (P : s -> b × s -> Set) -> (s -> Set)
    wpState' {b} t P s = wpState {a = ⊤} {b} (\_ -> t) (\{(tt , s') y -> P s' y}) (tt , s)

module Nondeterminism where

  open Free hiding (_⊆_)
  open Maybe using (wpSpec; SpecK; [[_,_]])
  data C : Set where
    Fail : C
    Choice : C

  R : C -> Set
  R Fail   = ⊥
  R Choice = Bool

  ND : Set -> Set
  ND = Free C R

  fail : forall {a} -> ND a
  fail = Step Fail (\())

  choice : forall {a} -> ND a -> ND a -> ND a
  choice c1 c2 = Step Choice (\b -> if b then c1 else c2)

  allPT : forall {a : Set} -> {b : a -> Set} -> (P : (x : a) -> b x -> Set) -> (x : a) -> ND (b x) -> Set
  allPT P _ (Pure x)        = P _ x
  allPT P _ (Step Fail k)   = ⊤
  allPT P _ (Step Choice k) = allPT P _ (k True) ∧ allPT P _ (k False)

  wpAll : forall {a   : Set} -> {b : a -> Set} -> ((x : a) -> ND (b x)) -> (P : (x : a) -> b x -> Set) -> (a -> Set)
  wpAll f P = wp f (allPT P)

  anyPT : forall {a : Set} -> {b : a -> Set} -> (P : (x : a) -> b x -> Set) -> (x : a) -> ND (b x) -> Set
  anyPT P _ (Pure x)        = P _ x
  anyPT P _ (Step Fail k)   = ⊥
  anyPT P _ (Step Choice k) = anyPT P _ (k True) ∨ anyPT P _ (k False)

  wpAny : forall {a   : Set} -> {b : a -> Set} -> ((x : a) -> ND (b x)) -> (P : (x : a) -> b x -> Set) -> (a -> Set)
  wpAny f P = wp f (anyPT P)

  run : forall {a} -> ND a -> List a
  run (Pure x)        = [ x ]
  run (Step Fail _)   = Nil
  run (Step Choice k) = run (k True) ++ run (k False)

  All : {a : Set} -> (a -> Set) -> List a -> Set
  All P Nil = ⊤
  All P (x :: xs) = P x ∧ All P xs

  All++ : {a : Set} (P : a -> Set) (xs ys : List a) ->
    All P xs -> All P ys -> All P (xs ++ ys)
  All++ P Nil ys H1 H2 = H2
  All++ P (x :: xs) ys (Px , H1) H2 = Px , All++ P xs ys H1 H2

  allSoundness : {a : Set} {b : a -> Set} (P : (x : a) -> b x -> Set) (x : a) (nd : ND (b x)) ->
    allPT P x nd -> All (P x) (run nd)
  allSoundness P x (Pure y) H = H , tt
  allSoundness P x (Step Fail _) H = tt
  allSoundness P x (Step Choice k) (H1 , H2) =
    All++ (P x) (run (k True)) (run (k False)) (allSoundness P x (k True) H1) (allSoundness P x (k False) H2)

  wpAllSoundness : forall {a} -> {b : a -> Set} -> (f : (x : a) -> ND (b x)) ->
    ∀ P x -> wpAll f P x -> All (P x) (run (f x))
  wpAllSoundness nd P x H = allSoundness P x (nd x) H
  data Elem {a : Set} (x : a) : ND a -> Set where
      Here   : Elem x (Pure x)
      Left   : forall {k} ->  Elem x (k True)  -> Elem x (Step Choice k)
      Right  : forall {k} ->  Elem x (k False) -> Elem x (Step Choice k)

  _⊆_ : forall {a} -> ND a -> ND a -> Set
  nd1 ⊆ nd2 = ∀ x -> Elem x nd1 -> Elem x nd2

  _<->_ : {l l' : Level} (a : Set l) (b : Set l') -> Set (l ⊔ l')
  a <-> b = Pair (a -> b) (b -> a)

  refineAll  : {a b : Set} {x : a} (f g : a -> ND b) -> (wpAll f  ⊑ wpAll g)  <-> ((x : a) -> g x  ⊆ f x)

  refineAny  : {a b : Set} {x : a} (f g : a -> ND b) -> (wpAny f  ⊑ wpAny g)  <-> ((x : a) -> f x  ⊆ g x)
  allP : ∀ {a b : Set} {x : a} P (S : ND b) -> allPT P x S <-> (∀ y -> Elem y S -> P x y)
  Pair.fst (allP P (Pure y)) H y Here = H
  Pair.fst (allP P (Step Choice k)) (H , _) y (Left i) = Pair.fst (allP P (k True)) H y i
  Pair.fst (allP P (Step Choice k)) (_ , H) y (Right i) = Pair.fst (allP P (k False)) H y i
  Pair.snd (allP P (Pure y)) H = H y Here
  Pair.snd (allP P (Step Fail k)) H = tt
  Pair.snd (allP P (Step Choice k)) H = (Pair.snd (allP P (k True)) λ y i -> H y (Left i)) , (Pair.snd (allP P (k False)) λ y i -> H y (Right i))

  anyP : ∀ {a b : Set} {x : a} P (S : ND b) -> anyPT P x S <-> Sigma b λ y -> Elem y S ∧ P x y
  Pair.fst (anyP P (Pure y)) H = y , (Here , H)
  Pair.fst (anyP P (Step Fail k)) ()
  Pair.fst (anyP P (Step Choice k)) (Inl H) with Pair.fst (anyP P (k True)) H
  Pair.fst (anyP P (Step Choice k)) (Inl H) | y , (i , IH) = y , (Left i , IH)
  Pair.fst (anyP P (Step Choice k)) (Inr H) with Pair.fst (anyP P (k False)) H
  Pair.fst (anyP P (Step Choice k)) (Inr H) | y , (i , IH) = y , (Right i , IH)
  Pair.snd (anyP P (Pure y)) (.y , (Here , H)) = H
  Pair.snd (anyP P (Step .Choice k)) (y , (Left i , H)) = Inl (Pair.snd (anyP P (k True)) (y , (i , H)))
  Pair.snd (anyP P (Step .Choice k)) (y , (Right i , H)) = Inr (Pair.snd (anyP P (k False)) (y , (i , H)))

  Pair.fst (refineAll f g) H x y i = Pair.fst (allP (λ _ y' -> Elem y' (f x)) (g x)) (H _ x (Pair.snd (allP _ (f x)) (λ _ -> id))) y i
  Pair.snd (refineAll f g) r P x H = Pair.snd (allP P (g x)) λ y i -> Pair.fst (allP P (f x)) H y (r x y i)
  Pair.fst (refineAny f g) H x y i with Pair.fst (anyP (λ _ y' -> y' == y) (g x)) (H _ x (Pair.snd (anyP _ (f x)) (y , (i , refl))))
  Pair.fst (refineAny f g) H x y i | .y , (i' , refl) = i'
  Pair.snd (refineAny f g) r P x H with Pair.fst (anyP P (f x)) H
  Pair.snd (refineAny f g) r P x H | y , (i , IH) = Pair.snd (anyP P (g x)) (y , ((r x y i) , IH))

  selectPost : forall {a} -> List a -> a × List a -> Set
  selectPost xs (y , ys) = Sigma (y ∈ xs) (\e -> delete xs e == ys)

  removeSpec : forall {a} -> SpecK (List a) (a × List a)
  removeSpec = [[ K ⊤ , selectPost ]]

  remove : forall {a} -> List a -> ND (a × List a)
  remove Nil       = fail
  remove (x :: xs) = choice  (return (x , xs)) (map (retain x) (remove xs))
      where
      retain : forall {a} -> a -> a × List a -> a × List a
      retain x (y , ys) = (y , (x :: ys))

  removeCorrect : forall {a} -> wpSpec {a = List a} {const (a × List a)} removeSpec ⊑ wpAll remove
  removeCorrect P Nil (tt , snd) = tt
  removeCorrect P (x :: xs) (tt , snd) =
    snd (x , xs) (∈Head , refl) ,
    mapPT P (x :: xs) xs (remove xs) _
      (removeCorrect _ xs (tt , (λ {(x' , xs') (i , H) -> snd (x' , (x :: xs')) (∈Tail i , cong (x ::_) H)})))
    where
    mapPT : ∀ {a b c : Set} P (x x' : a) (S : ND b) (f : b -> c) -> allPT (λ _ y -> P x (f y)) x' S -> allPT P x (map f S)
    mapPT P x x' (Pure y) f H = H
    mapPT P x x' (Step Fail k) f H = H
    mapPT P x x' (Step Choice k) f (fst , snd) = mapPT P x x' (k True) f fst , mapPT P x x' (k False) f snd

  trivialCorrect : forall {a} -> wpSpec {a = List a} {const (a × List a)} removeSpec ⊑ wpAll (const fail)
  trivialCorrect = \P xs H -> tt

  completeness : forall {a} -> (y : a) (xs ys : List a) -> selectPost xs (y , ys) -> Elem (y , ys) (remove xs)
  completeness y (y :: _) ys (∈Head , refl) = Left Here
  completeness y (x :: xs) .(x :: delete xs fst) (∈Tail fst , refl) = Right (inMap _ (remove xs) _ (completeness y _ _ (fst , refl)))
    where
    inMap : ∀ {a b : Set} (x : a) S (f : a -> b) -> Elem x S -> Elem (f x) (map f S)
    inMap x (Pure x) f Here = Here
    inMap x (Step Choice k) f (Left i) = Left (inMap x (k True) f i)
    inMap x (Step Choice k) f (Right i) = Right (inMap x (k False) f i)

module Recursion where
  open Free
  open import Data.Nat public
    using
      (_+_; _>_; _*_
      )
    renaming
      ( ℕ to Nat
      ; zero to Zero
      ; suc to Succ
      ; _∸_ to _-_
      )
  open NaturalLemmas
  open Maybe hiding (soundness)

  _~~>_ : (I : Set) (O : I -> Set) -> Set
  I ~~> O = (i : I) -> Free I O (O i)

  call : forall {I O} -> (i : I) -> Free I O (O i)
  call x = Step x Pure

  f91 : Nat ~~> K Nat
  f91 i with 100 lt i
  f91 i | yes  _ = return (i - 10)
  f91 i | no   _ = call (i + 11) >>= call

  f91Post : Nat -> Nat -> Set
  f91Post i o with 100 lt i
  f91Post i o | yes _ = o == i - 10
  f91Post i o | no _  = o == 91

  f91Spec : SpecK Nat Nat
  f91Spec = [[ K ⊤ , f91Post ]]

  invariant : forall {I} -> {O : I -> Set} -> (i : I) -> Spec I O -> Free I O (O i) -> Set
  invariant i [[ pre , post ]] (Pure x)   =  pre i -> post i x
  invariant i [[ pre , post ]] (Step j k) =  (pre i -> pre j)
                                              ∧ ∀ o -> post j o -> invariant i [[ pre , post ]] (k o)
  wpRec : forall {I} -> {O : I -> Set} -> Spec I O -> (f : I ~~> O) -> (P : (i : I) -> O i -> Set) -> (I -> Set)
  wpRec spec f P i = wpSpec spec P i ∧ invariant i spec (f i)

  f91Partial-correctness : wpSpec f91Spec ⊑ wpRec f91Spec f91
  f91Partial-correctness P i with 100 lt i
  f91Partial-correctness P i | yes p with 100 lt i
  f91Partial-correctness P i | yes p | yes _ = \H -> (tt , (\x eq -> Pair.snd H _ eq)) , (\x -> refl)
  f91Partial-correctness P i | yes p | no ¬p = magic (¬p p)
  f91Partial-correctness P i | no ¬p = \x -> (tt , (\x₁ x₂ -> Pair.snd x x₁ x₂)) ,
                                              ((\_ -> tt) , (\o x₁ -> (\x₂ -> tt) ,
                                              (\o₁ x₂ x₃ -> lemma i o _ ¬p x₁ x₂)))
    where
    open Data.Nat
    open import Data.Nat.Properties

    100-≮-91 : (i : Nat) -> ¬ (i + 10 ≤ i)
    100-≮-91 Zero ()
    100-≮-91 (Succ i) (s≤s pf) = 100-≮-91 i pf

    plus-minus : ∀ b c -> (b + c) - c == b
    plus-minus b c = trans (+-∸-assoc b (NaturalLemmas.≤-refl {c})) (trans (cong (b +_) (n∸n≡0 c)) (sym (plus-zero b)))

    plus-plus-minus : ∀ i -> i + 11 - 10 ≡ Succ i
    plus-plus-minus i = plus-minus (Succ i) 11

    between : ∀ a b -> ¬ (a < b) -> a < Succ b -> a ≡ b
    between Zero Zero ¬lt ltSucc = refl
    between Zero (Succ b) ¬lt ltSucc = magic (¬lt (s≤s z≤n))
    between (Succ a) Zero ¬lt (s≤s ())
    between (Succ a) (Succ b) ¬lt (s≤s ltSucc) = cong Succ (between a b (¬lt ∘ s≤s) ltSucc)

    lemma : ∀ i o o' -> ¬ (100 < i) ->
      f91Post (i + 11) o -> f91Post o o' -> f91Post i o'
    lemma i o o' i≤100 oPost o'Post with 100 lt i
    ... | yes p = magic (i≤100 p)
    ... | no ¬p with 100 lt o
    lemma i o .(o - 10) i≤100 oPost refl | no ¬p | yes p with 100 lt (i + 11)
    lemma i .(i + 11 - 10) .(i + 11 - 10 - 10) i≤100 refl refl | no ¬p | yes p | yes p₁ with between 100 i i≤100 (subst (\i' -> 100 < i') (plus-plus-minus i) p)
    lemma .100 .101 .91 i≤100 refl refl | no ¬p | yes p | yes p₁ | refl = refl
    lemma i .91 .81 i≤100 refl refl | no ¬p | yes p | no ¬p₁ = magic (100-≮-91 91 p)
    lemma i o o' i≤100 oPost o'Post | no ¬p | no ¬p₁ = o'Post

  petrol : forall {I O a} -> (f : I ~~> O) -> Free I O a -> Nat -> Partial a
  petrol f (Pure x)    n        = return x
  petrol f (Step _ _)  Zero     = abort
  petrol f (Step c k)  (Succ n) = petrol f (f c >>= k) n

  mayPT : forall {a} -> (a -> Set) -> (Partial a -> Set)
  mayPT P (Pure x)       = P x
  mayPT P (Step Abort _) = ⊤

  soundness : forall {I O} -> (f : I ~~> O) (spec : Spec I O) (P : (i : I) -> O i -> Set) ->
    (∀ i -> wpRec spec f P i) -> ∀ n i -> mayPT (P i) (petrol f (f i) n)
  soundness f spec P wpH n i = soundness' f spec P (f i) n wpH (wpH i)
    where
    invariant-compositionality : ∀ {I} {O : I -> Set} {i i'} spec
      (S : Free I O (O i)) (k : (O i) -> Free I O (O i')) ->
      invariant i spec S -> Spec.pre spec i -> (∀ o -> Spec.post spec i o -> invariant i' spec (k o)) ->
      invariant i' spec (S >>= k)
    invariant-compositionality spec (Pure x) k SH preH kH = kH x (SH preH)
    invariant-compositionality spec (Step c k') k (fst , snd) preH kH = (\_ -> fst preH) , \o postH -> invariant-compositionality spec (k' o) k (snd o postH) preH kH
    soundness' : ∀ {I} {O : I -> Set} {i}
      (f : (i : I) -> Free I O (O i)) (spec : Spec I O) (P : (i : I) -> O i -> Set)
      (S : Free I O (O i)) (n : Nat) ->
      (∀ i -> wpRec spec f P i) ->
      wpSpec spec P i ∧ invariant i spec S ->
      mayPT (P i) (petrol f S n)
    soundness' f spec P (Pure x) n wpH ((preH , postH) , invH) = postH x (invH preH)
    soundness' f spec P (Step c k) Zero wpH H = tt
    soundness' f spec P (Step c k) (Succ n) wpH (specH , (preH , postH)) = soundness' f spec P (f c >>= k) n wpH (specH , invariant-compositionality spec (f c) k (Pair.snd (wpH c)) (preH (Pair.fst specH)) postH)

module Mix (C : Set) (R : C -> Set) (ptalgebra : (c : C) -> (R c -> Set) -> Set) where
  open Free hiding (_>>=_)
  open Maybe using (SpecK; [[_,_]]; Spec; wpSpec)

  SpecVal : Set -> Set₁
  SpecVal a = SpecK ⊤ a

  data I (a : Set) : Set₁ where
    Done  : a -> I a
    Hole  : SpecVal a -> I a

  ptI : forall {a} -> I a -> (a -> Set) -> Set
  ptI (Done x)     P = P x
  ptI (Hole spec)  P = wpSpec spec (const P) tt

  M : Set -> Set₁
  M a = Free C R (I a)

  isExecutable : forall {a} -> M a -> Set
  isExecutable (Pure (Done _)) = ⊤
  isExecutable (Pure (Hole _)) = ⊥
  isExecutable (Step c k)      = ∀ r -> isExecutable (k r)

  pt : forall {l} -> {a : Set l} -> Free C R a -> (a -> Set) -> Set
  pt (Pure x) P   = P x
  pt (Step c x) P = ptalgebra c (\r -> pt (x r) P)

  wpCR : forall {l l'} -> {a : Set l} -> {b : a -> Set l'} -> ((x : a) -> Free C R (b x)) -> ((x : a) -> b x -> Set) -> (a -> Set)
  wpCR f P x = pt (f x) (P x)

  wpM : {a : Set} -> {b : a -> Set} -> ((x : a) -> M (b x)) -> ((x : a) -> b x -> Set) -> (a -> Set)
  wpM f P x = wpCR f (\x ix -> ptI ix (P x)) x

module StateExample where
  open Free hiding (_>>=_)
  open Maybe using (Spec; SpecK; [[_,_]]; wpSpec)
  open State Nat

  --   We have to redo the Mix section since our specifications incorporate the state
  SpecVal : ∀ {l} -> Set -> Set (suc l)
  SpecVal = SpecK Nat

  data I {l : Level} (a : Set) : Set (suc l) where
    Done  : a -> I a
    Hole  : SpecVal {l} (a × Nat) -> I a

  M : {l : Level} -> Set -> Set (suc l)
  M a = State (I a)

  ptI : forall {l a} -> I a -> (a × Nat -> Set l) -> Nat -> Set l
  ptI (Done x)     P t = P (x , t)
  ptI (Hole spec)  P t = wpSpec spec (\_ -> P) t

  wpM : forall {l l'} {a : Set l} {b : Set} -> (a -> M b) -> (a × Nat -> b × Nat -> Set l') -> (a × Nat -> Set l')
  wpM f P = wpState f (\i o -> ptI (Pair.fst o) (P i) (Pair.snd o))

  ptM : {a : Set} -> M a -> (Nat -> a × Nat -> Set) -> (Nat -> Set)
  ptM S post t = wpM (λ _ -> S) (λ _ -> (post t)) (⊤ , t)

  liftM : ∀ {l : Level} {a} -> M {l} a -> M {suc l} a
  liftM (Pure (Done x)) = Pure (Done x)
  liftM (Pure (Hole [[ pre , post ]])) = Pure (Hole [[ (λ x -> Lift _ (pre x)) , (λ i o -> Lift _ (post i o)) ]])
  liftM (Step c k) = Step c λ x -> liftM (k x)

  _>>=_ : forall {l a b} -> (M {l} a) -> (a -> M {l} b) -> M {suc l} b
  Pure (Done x)                >>= f = liftM (f x)
  Pure (Hole [[ pre , post ]]) >>= f =
    Pure (Hole [[ (λ n -> Lift _ (pre n)) ,
      (\i ynat -> ∀ x -> post i (x , i) -> ∀ P -> wpM f P (x , i) -> P (x , i) ynat
      ) ]] )
  (Step c k) >>= f        = Step c (\r -> k r >>= f)

  _>=>_ : forall {l : Level} {a b c : Set} -> (a -> M {l} b) -> (b -> M {l} c) -> a -> M {suc l} c
  (f >=> g) x = f x >>= g

  specV : {a : Set} -> SpecVal {zero} (a × Nat) -> M a
  specV spec = Pure (Hole spec)

  done   : forall {a} -> a -> M {zero} a
  get'   : M Nat
  put'   : Nat -> M ⊤
  done x = Pure (Done x)
  get' = Step Get done
  put' t = Step (Put t) done

  getPost : Nat -> Nat × Nat -> Set
  getPost t (x , t') = (t == x) ∧ (t == t')

  putPost : Nat -> Nat -> ⊤ × Nat -> Set
  putPost t _ (_ , t') = t == t'

  _▹_ : {a b : Set} -> (Q : a -> b -> Set) (P : a -> Set) -> b -> Set
  _▹_ {a} Q P = \y -> Sigma a (\x -> P x ∧ Q x y)
  _◃_ : {a b c : Set} -> (Q : a -> b -> Set) -> (SpecK a c) -> b -> c -> Set
  _◃_ Q [[ pre , post ]] = \y z -> ∀ x -> pre x ∧ Q x y -> post x z

  step : forall {b} -> (c : C) (spec : SpecVal {zero} (b × Nat)) -> SpecK {zero} (R c × Nat) (b × Nat)
  step Get      [[ pre , post ]] = [[ getPost ▹ pre , getPost ◃ [[ pre , post ]] ]]
  step (Put x)  [[ pre , post ]] = [[ (putPost x) ▹ pre , (putPost x) ◃ [[ pre , post ]] ]]

  intros : forall {a b} -> SpecK {zero} (a × Nat) (b × Nat) -> a -> SpecVal (b × Nat)
  intros [[ pre , post ]] x = [[ (\t -> pre (x , t)) , (\t -> post (x , t)) ]]

  data Derivation {b} (spec : SpecVal (b × Nat)) : Set₁ where
    Done : (x : b) -> wpSpec spec ⊑ ptM (done x) -> Derivation spec
    Step : (c : C) -> (∀ (r : R c) -> Derivation (intros (step c spec) r)) -> Derivation spec

  extract : forall {b} -> (spec : SpecVal (b × Nat)) -> Derivation spec -> State b
  extract _ (Done x _) = Pure x
  extract _ (Step c k) = Step c (\r -> extract _ (k r))

  DerivationFun : {a b : Set} (spec : SpecK (a × Nat) (b × Nat)) -> Set₁
  DerivationFun {a} {b} spec = (x : a) -> Derivation (intros spec x)

  stepMonotone : {a : Set} (c : C) (r : R c) {spec spec' : SpecVal (a × Nat)} ->
    wpSpec spec ⊑ wpSpec spec' ->
    wpSpec (intros (step c spec) r) ⊑ wpSpec (intros (step c spec') r)
  stepMonotone {a} Get r {spec} {spec'} H P .r ((.r , (fst₁ , (refl , refl))) , snd) = (r , (Pair.fst (H (\_ _ -> ⊤) r (fst₁ , (\x _ -> tt))) , (refl , refl))) , \x x₁ -> snd x (postLemma r x x₁)
    where
    postLemma : ∀ r
      (x : Pair a Nat) ->
      (∀ x₁ ->
      Pair (Spec.pre spec' x₁) (Pair (x₁ ≡ r) (x₁ ≡ r)) ->
      Spec.post spec' x₁ x) ->
      ∀ x₁ ->
      Pair (Spec.pre spec x₁) (Pair (x₁ ≡ r) (x₁ ≡ r)) ->
      Spec.post spec x₁ x
    postLemma r x x₂ .r (fst , (refl , refl)) = Pair.snd (H (Spec.post spec) r (fst , (\x₃ z -> z))) x (x₂ r ((Pair.fst (H (\_ _ -> ⊤) r (fst , (\x₃ _ -> tt)))) , (refl , refl)))
  stepMonotone {a} (Put t) r {spec} {spec'} H P .t ((fst , (fst₁ , refl)) , snd) = (fst , (Pair.fst (H (\_ _ -> ⊤) fst (fst₁ , (\x _ -> tt))) , refl)) , \x x₁ -> snd x (postLemma t x x₁)
    where
      postLemma : ∀ (t : Nat)
        (x : Pair a Nat) ->
        (∀ x₁ -> Pair (Spec.pre spec' x₁) (t ≡ t) -> Spec.post spec' x₁ x) ->
        ∀ x₁ ->
        Pair (Spec.pre spec x₁) (t ≡ t) -> Spec.post spec x₁ x
      postLemma t x x₁ x₂ (fst , refl) = Pair.snd (H (Spec.post spec) x₂ (fst , (\x₃ z -> z))) x (x₁ x₂ ((Pair.fst (H (\_ _ -> ⊤) x₂ (fst , (\x₃ _ -> tt)))) , refl))

  open import Data.Nat
  open import Data.Nat.Properties
  open NaturalLemmas hiding (≤-refl ; ≤-trans)

  data All {a : Set} (P : a -> Set) : List a -> Set where
    AllNil : All P Nil
    AllCons : ∀ {x xs} -> P x -> All P xs -> All P (x :: xs)

  unAllCons : ∀ {a P x} {xs : List a} ->
    All P (x :: xs) -> All P xs
  unAllCons (AllCons x₁ x₂) = x₂

  maxPre : List Nat × Nat -> Set
  maxPre (xs , i) = (i == 0) ∧ (¬ (xs == Nil))

  maxPost : List Nat × Nat -> Nat × Nat -> Set
  maxPost (xs , i) (o , _) = All (o ≥_) xs ∧ (o ∈ xs)

  maxSpec = [[ maxPre , maxPost ]]

  refineDerivation : forall {a : Set} -> {spec spec' : SpecVal (a × Nat)} -> wpSpec spec ⊑ wpSpec spec' -> Derivation spec' -> Derivation spec
  refineDerivation H (Done x Hx) = Done x (⊑-trans H Hx)
  refineDerivation H (Step c d) = Step c \r -> refineDerivation (stepMonotone c r H) (d r)

  maxPost' : List Nat × Nat -> Nat × Nat -> Set
  maxPost' (xs , i) (o , _) = All (o ≥_) (i :: xs) × (o ∈ (i :: xs))

  maxProof : ∀ (xs : List Nat) ->
    wpSpec (intros [[ maxPre , maxPost ]] xs) ⊑
    wpSpec (intros [[ K ⊤ , maxPost' ]] xs)
  maxProof xs P .0 ((refl , Hnil) , snd) = tt , \o H -> snd o (unAllCons (Pair.fst H) , lemma xs Hnil (Pair.fst o) H)
    where
    lemma : ∀ xs -> ¬ (xs == Nil) ->
      ∀ w -> Pair (All (\n -> n ≤ w) (0 :: xs)) (w ∈ (0 :: xs)) -> w ∈ xs
    lemma Nil Hnil w H = magic (Hnil refl)
    lemma (.0 :: xs) _ .0 (AllCons x₂ (AllCons z≤n fst) , ∈Head) = ∈Head
    lemma (x :: xs) _ w (_ , ∈Tail snd) = snd

  max'ProofNil : ∀ i ->
    wpSpec (intros (step Get (intros [[ K ⊤ , maxPost' ]] Nil)) i) ⊑ ptM (done i)
  max'ProofNil i P .i ((.i , (fst₁ , (refl , refl))) , snd) = snd (i , i) (lemma i)
    where
    lemma : ∀ i x ->
      Pair ⊤ (Pair (x ≡ i) (x ≡ i)) ->
      Pair (All (\n -> n ≤ i) (x :: Nil)) (i ∈ (x :: Nil))
    lemma i .i (fst , (refl , refl)) = (AllCons ≤-refl AllNil) , ∈Head

  max'Proof1 : ∀ x xs i ->
    Succ x ≤ i ->
    ∀ (P : Nat -> Nat × Nat -> Set) x₁ ->
    Pair (Sigma ℕ (\x₂ -> Pair ⊤ (Pair (x₂ ≡ i) (x₂ ≡ x₁))))
    (∀ x₂ ->
    (∀ x₃ ->
    Pair ⊤ (Pair (x₃ ≡ i) (x₃ ≡ x₁)) ->
    Pair (All (\n -> n ≤ Pair.fst x₂) (x₃ :: x :: xs))
    (Pair.fst x₂ ∈ (x₃ :: x :: xs))) ->
    P x₁ x₂) ->
    Pair ⊤
    (∀ x₂ ->
    Pair (All (\n -> n ≤ Pair.fst x₂) (x₁ :: xs))
    (Pair.fst x₂ ∈ (x₁ :: xs)) ->
    P x₁ x₂)
  max'Proof1 x xs i x<i P .i ((.i , (_ , (refl , refl))) , snd) = tt , \x₂ x₁ -> snd x₂ (lemma x₂ x₁)
    where
    lemma : ∀ (x₂ : Nat × Nat) ->
      Pair (All (\n -> n ≤ Pair.fst x₂) (i :: xs))
      (Pair.fst x₂ ∈ (i :: xs)) ->
      ∀ x₃ -> Pair ⊤ (Pair (x₃ ≡ i) (x₃ ≡ i)) ->
      Pair (All (\n -> n ≤ Pair.fst x₂) (x₃ :: x :: xs))
      (Pair.fst x₂ ∈ (x₃ :: x :: xs))
    lemma x₂ (AllCons x₁ fst , ∈Head) .i (_ , (refl , refl)) = (AllCons x₁ (AllCons (<⇒≤ x<i) fst)) , ∈Head
    lemma x₂ (AllCons x₁ fst , ∈Tail snd) _ (_ , (refl , refl)) = (AllCons x₁ (AllCons (≤-trans (<⇒≤ x<i) x₁) fst)) , ∈Tail (∈Tail snd)

  max'Proof2 : ∀ i x xs -> (Succ x ≤ i -> ⊥) ->
    ∀ (P : Nat -> Nat × Nat -> Set) x₁ -> Pair (Sigma ℕ (\x₂ -> Pair (Sigma ℕ (\x₃
    -> Pair ⊤ (Pair (x₃ ≡ i) (x₃ ≡ x₂)))) (x ≡ x₁))) (∀ x₂ -> (∀ x₃ -> Pair (Sigma
    ℕ (\x₄ -> Pair ⊤ (Pair (x₄ ≡ i) (x₄ ≡ x₃)))) (x ≡ x₁) -> ∀ x₄ -> Pair ⊤ (Pair
    (x₄ ≡ i) (x₄ ≡ x₃)) -> Pair (All (\n -> n ≤ Pair.fst x₂) (x₄ :: x :: xs))
    (Pair.fst x₂ ∈ (x₄ :: x :: xs))) -> P x₁ x₂) -> Pair ⊤ (∀ x₂ -> Pair (All (\n
    -> n ≤ Pair.fst x₂) (x₁ :: xs)) (Pair.fst x₂ ∈ (x₁ :: xs)) -> P x₁ x₂)
  max'Proof2 i x xs x≥i P .x ((.i , ((.i , (fst₂ , (refl , refl))) , refl)) , snd) = tt , \x₄ x₁ -> snd x₄ (lemma x₄ x₁)
    where
    lemma : ∀ (x₄ : Pair Nat Nat) -> Pair (All (\n -> n ≤ Pair.fst x₄) (x :: xs))
      (Pair.fst x₄ ∈ (x :: xs)) -> ∀ x₃ -> Pair (Sigma ℕ (\x₅ -> Pair ⊤ (Pair (x₅
      ≡ i) (x₅ ≡ x₃)))) (x ≡ x) -> ∀ x₅ -> Pair ⊤ (Pair (x₅ ≡ i) (x₅ ≡ x₃)) -> Pair
      (All (\n -> n ≤ Pair.fst x₄) (x₅ :: x :: xs)) (Pair.fst x₄ ∈ (x₅ :: x :: xs))
    lemma (_ , _) (AllCons x fst , ∈Head) _ ((_ , (_ , (refl , refl))) , refl) _ (_ , (refl , refl)) = (AllCons (≮⇒≥ x≥i) (AllCons x fst)) , (∈Tail ∈Head)
    lemma x₄ (AllCons x₁ fst , ∈Tail snd) _ ((_ , (_ , (refl , refl))) , refl) _ (_ , (refl , refl)) = (AllCons (≤-trans (≮⇒≥ x≥i) x₁) (AllCons x₁ fst)) , (∈Tail (∈Tail snd))

  maxSpec' = [[ K ⊤ , maxPost' ]]

  max' : (xs : List Nat) -> Derivation (intros maxSpec' xs)
  max' Nil       = Step Get \i ->
                     Done i (max'ProofNil i)
  max' (x :: xs) = Step Get \i ->
                     if' x <? i
                       then (\lt  -> refineDerivation (max'Proof1 x xs i lt) (max' xs))
                       else (\geq -> Step (Put x) (const (refineDerivation (max'Proof2 i x xs geq) (max' xs))))

  max : DerivationFun [[ maxPre , maxPost ]]
  max xs = refineDerivation (maxProof xs) (max' xs)


Typo.

Typo.

Ignore-this: e2f62b5566a19cf8a9d583c54f8ec894

darcs-hash:20120319115721-3bd4e-373cf4510c7d80b8fa0d5e852e64cffe382074d3.gz

------------------------------------------------------------------------------
-- Reasoning partially about functions
------------------------------------------------------------------------------

-- We cannot reasoning partially about partial functions intended to
-- operate in total values.

-- Tested with FOT on 19 March 2012.

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

module Draft.FOTC.Data.Nat.AddPartialRightIdentity where

open import FOTC.Base
open import FOTC.Data.Nat

-- How proceed?
+-partialRightIdentity : ∀ n → n + zero ≡ n
+-partialRightIdentity n = {!!}

------------------------------------------------------------------------------
-- Reasoning partially about functions
------------------------------------------------------------------------------

-- We cannot reasoning partially about partial functions intended to
-- operate in total values.

-- Tested with FOT and agda2atp on 17 March 2012.

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

module Draft.FOTC.Data.Nat.AddPartialRightIdentity where

open import FOTC.Base
open import FOTC.Data.Nat

-- How proceed?
+-partialRightIdentity : ∀ n → n + zero ≡ n
+-partialRightIdentity n = {!!}


Upgrade: CCA2d-CCA2

Upgrade: CCA2d-CCA2

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

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Control.Strategy renaming (run to runStrategy; map to mapStrategy)

open import Function

open import Relation.Binary.PropositionalEquality

import Game.IND-CPA-utils
import Game.IND-CCA2-dagger
import Game.IND-CCA2
import Game.IND-CCA

module Game.Transformation.CCA2d-CCA2
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

module CCA2d = Game.IND-CCA2-dagger PubKey SecKey Message CipherText Rₑ Rₖ Rₐ KeyGen Enc Dec
module CCA2  = Game.IND-CCA2        PubKey SecKey Message CipherText Rₑ Rₖ Rₐ KeyGen Enc Dec
open Game.IND-CPA-utils Message CipherText
open TransformAdversaryResponse {DecRound Bit} {CipherText → DecRound Bit} (λ x _ → x)

A-transform : (adv : CCA2.Adversary) → CCA2d.Adversary
A-transform adv rₐ pk = mapStrategy A* (adv rₐ pk)

{-
If we are able to do the transformation, then we get the same advantage
-}

decRound = runStrategy ∘ Dec

correct : ∀ {rₑ rₑ' rₖ rₐ } b adv
        → CCA2.EXP b adv               (rₐ , rₖ , rₑ)
        ≡ CCA2d.EXP b (A-transform adv) (rₐ , rₖ , rₑ , rₑ')
correct {rₑ} {rₑ'} {rₖ} {rₐ} 0b m with KeyGen rₖ
... | pk , sk = cong (λ x → decRound sk (put-c x (Enc pk (proj₁ (get-m x)) rₑ)
                                                 (Enc pk (proj₂ (get-m x)) rₑ')))
                     (sym (run-map (Dec sk) A* (m rₐ pk)))
correct {rₑ}{rₑ'}{rₖ} {rₐ} 1b m with KeyGen rₖ
... | pk , sk = cong (λ x → decRound sk (put-c x (Enc pk (proj₂ (get-m x)) rₑ)
                                                 (Enc pk (proj₁ (get-m x)) rₑ')))
                     (sym (run-map (Dec sk) A* (m rₐ pk)))
{-

Need to show that they are valid transformation aswell:

  This is not obvious that it will always work since the original adversary might
  ask for the ciphertext from the rₑ' supply.

  The argument why this is unlikely (in the paper) is that the construction is
  IND-CPA secure and therefor it is hard to predict a ciphertext.
  suppose that A could predict the ciphertext, then it could use this power to
  win the game. Since he can predict what Enc(m(not b)) is he could just check what the
  ciphertext was and that he received and thereby know if he received b or not b.

-}

{-
valid : ∀ adv → CCA2.Valid-Adv adv → CCA2d.Valid-Adv (A-transform adv)
valid adv valid = {!!} -- can't prove this strictly, but it will deviate with
                       -- non-neg probability

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

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

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Control.Strategy renaming (run to runStrategy; map to mapStrategy)

open import Function

open import Relation.Binary.PropositionalEquality

import Game.IND-CPA-utils
import Game.IND-CCA2-dagger
import Game.IND-CCA2
import Game.IND-CCA

module Game.Transformation.CCA2d-CCA2
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

module CCA2d = Game.IND-CCA2-dagger PubKey SecKey Message CipherText Rₑ Rₖ Rₐ KeyGen Enc Dec
module CCA2  = Game.IND-CCA2        PubKey SecKey Message CipherText Rₑ Rₖ Rₐ KeyGen Enc Dec
open Game.IND-CPA-utils Message CipherText

f : CPAAdversary (DecRound Bit)
  → CPAAdversary (CipherText → DecRound Bit)
get-m (f A) = get-m A
put-c (
f (m , g) = m , λ c _ → g c

A-transform : (adv : CCA2.Adversary) → CCA2d.Adversary
A-transform adv rₐ pk = mapStrategy f (adv rₐ pk)

{-

If we are able to do the transformation, then we get the same advantage

-}

decRound = runStrategy ∘ Dec

correct : ∀ {rₑ rₑ' rₖ rₐ } b adv
        → CCA2.EXP b adv               (rₐ , rₖ , rₑ)
        ≡ CCA2d.EXP b (A-transform adv) (rₐ , rₖ , rₑ , rₑ')
correct {rₑ} {rₑ'} {rₖ} {rₐ} 0b m with KeyGen rₖ
... | pk , sk = cong (λ x → decRound sk (proj₂ x (Enc pk (proj₁ (proj₁ x)) rₑ)
                                             (Enc pk (proj₂ (proj₁ x)) rₑ')))
                     (sym (run-map (Dec sk) f (m rₐ pk)))
correct {rₑ}{rₑ'}{rₖ} {rₐ} 1b m with KeyGen rₖ
... | pk , sk = cong (λ x → decRound sk (proj₂ x (Enc pk (proj₂ (proj₁ x)) rₑ)
                                             (Enc pk (proj₁ (proj₁ x)) rₑ')))
                     (sym (run-map (Dec sk) f (m rₐ pk)))
{-

Need to show that they are valid transformation aswell:

  This is not obvious that it will always work since the original adversary might
  ask for the ciphertext from the rₑ' supply.

  The argument why this is unlikely (in the paper) is that the construction is
  IND-CPA secure and therefor it is hard to predict a ciphertext.
  suppose that A could predict the ciphertext, then it could use this power to
  win the game. Since he can predict what Enc(m(not b)) is he could just check what the
  ciphertext was and that he received and thereby know if he received b or not b.

-}

{-
valid : ∀ adv → CCA2.Valid-Adv adv → CCA2d.Valid-Adv (A-transform adv)
valid adv valid = {!!} -- can't prove this strictly, but it will deviate with
                       -- non-neg probability

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


Simplified a proof.

Simplified a proof.

------------------------------------------------------------------------------
-- Properties for the equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

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

stream-≈-refl : ∀ {xs} → Stream xs → xs ≈ xs
stream-≈-refl {xs} Sxs = ≈-coind R h₁ h₂
  where
  R : D → D → Set
  R xs ys = Stream xs ∧ xs ≡ ys

  h₁ : ∀ {xs ys} → R xs ys → ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
       R xs' ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  h₁ (Sxs , refl) with (Stream-unf Sxs)
  ... | x' , xs' , Sxs' , prf = x' , xs' , xs' , (Sxs' , refl) , prf , prf

  h₂ : R xs xs
  h₂ = Sxs , refl

stream-≡→≈ : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
stream-≡→≈ Sxs _ refl = stream-≈-refl Sxs

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = Stream-coind P₁ h₁ (ys , h) , Stream-coind P₂ h₂ (xs , h)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  h₁ : ∀ {ws} → P₁ ws → ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  h₁ {ws} (zs , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , prf₂ , _ = w' , ws' , (zs' , prf₁) , prf₂

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  h₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  h₂  {zs} (ws , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , _ , prf₂ = w' , zs' , (ws' , prf₁) , prf₂

------------------------------------------------------------------------------
-- Properties for the equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

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

stream-≈-refl : ∀ {xs} → Stream xs → xs ≈ xs
stream-≈-refl {xs} Sxs = ≈-coind R h₁ h₂
  where
  R : D → D → Set
  R xs ys = Stream xs ∧ Stream xs ∧ xs ≡ ys

  h₁ : ∀ {xs ys} → R xs ys → ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
       R xs' ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  h₁ (Sxs , Sys , refl) with (Stream-unf Sxs)
  ... | x' , xs' , Sxs' , prf = x' , xs' , xs' , (Sxs' , Sxs' , refl) , prf , prf

  h₂ : R xs xs
  h₂ = Sxs , Sxs , refl

stream-≡→≈ : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
stream-≡→≈ Sxs _ refl = stream-≈-refl Sxs

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = Stream-coind P₁ h₁ (ys , h) , Stream-coind P₂ h₂ (xs , h)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  h₁ : ∀ {ws} → P₁ ws → ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  h₁ {ws} (zs , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , prf₂ , _ = w' , ws' , (zs' , prf₁) , prf₂

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  h₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  h₂  {zs} (ws , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , _ , prf₂ = w' , zs' , (ws' , prf₁) , prf₂


Closure validity: base env in change must match original env

This fixes *one* weirdness.

-- Step-indexed logical relations based on relational big-step semantics
-- for ILC-based incremental computation.

-- Goal: prove the fundamental lemma for a ternary logical relation (change
-- validity) across t1, dt and t2. The fundamnetal lemma relates t, derive t and
-- t. That is, we relate a term evaluated relative to an original environment,
-- its derivative evaluated relative to a valid environment change, and the
-- original term evaluated relative to an updated environment.
--
-- Missing goal: here ⊕ isn't defined and wouldn't yet agree with change
-- validity.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, including the choice of using ANF syntax
-- to simplify some step-indexing proofs.
--
-- In fact, this development is typed, hence some parts of the model are closer
-- to Ahmed (ESOP 2006), "Step-Indexed Syntactic Logical Relations for Recursive
-- and Quantified Types". But for many relevant aspects, the two papers are
-- very similar. In fact, I first defined similar logical relations
-- without types, but they require a trickier recursion scheme for well-founded
-- recursion, and I failed to do any proof in that setting.
--
-- The original inspiration came from Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but we ended up looking
-- at their source.
--
-- The main insight from the ISAC paper missing from the other one is how to
-- step-index a big-step semantics correctly: just ensure that the steps in the
-- big-step semantics agree with the ones in the small-step semantics. *Then*
-- everything just works with big-step semantics. Quite a few other details are
-- fiddly, but those are the same in small-step semantics.
--
-- The crucial novelty here is that we relate two computations on different
-- inputs. So we only conclude their results are related if both terminate; the
-- relation for computations does not prove that if the first computation
-- terminates, then the second terminates as well.
--
-- Instead, e1, de and e2 are related at k steps if, whenever e1 terminates in j
-- < k steps and e2 terminates with any step count, then de terminates (with any
-- step count) and their results are related at k - j steps.
--
-- Even when e1 terminates in j steps implies that e2 terminates, e2 gets no
-- bound. Similarly, we do not bound in how many steps de terminates, since on
-- big inputs it might take long.

module Thesis.StepIndexedRelBigStepTypedAnfIlcCorrect where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type
infixr 20 _⇒_

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) (τ : Type) : Set
-- Source values
data SVal (Γ : Context) : (τ : Type) → Set where
  var : ∀ {τ} →
    (x : Var Γ τ) →
    SVal Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    SVal Γ (σ ⇒ τ)
data Term (Γ : Context) (τ : Type) where
  val :
    SVal Γ τ →
    Term Γ τ
  -- constants aka. primitives
  const :
    (c : Const τ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  app : ∀ {σ}
    (vs : SVal Γ (σ ⇒ τ)) →
    (vt : SVal Γ σ) →
    Term Γ τ
  lett : ∀ {σ}
    (s : Term Γ σ) →
    (t : Term (σ • Γ) τ) →
    Term Γ τ

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  natV : ∀ (n : ℕ) → Val nat

import Data.Integer as I
open I using (ℤ)

-- Yann's idea.
data HasIdx : Set where
  true : HasIdx
  false : HasIdx
data Idx : HasIdx → Set where
  i' : ℕ → Idx true
  no : Idx false

i : {hasIdx : HasIdx} → ℕ → Idx hasIdx
i {false} j = no
i {true} j = i' j

module _ {hasIdx : HasIdx} where
  data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : ∀ {τ} → Term Γ τ → Idx hasIdx → Val τ → Set where
    abs : ∀ {σ τ} {t : Term (σ • Γ) τ} →
      ρ ⊢ val (abs t) ↓[ i 0 ] closure t ρ
    var : ∀ {τ} (x : Var Γ τ) →
      ρ ⊢ val (var x) ↓[ i 0 ] (⟦ x ⟧Var ρ)
    app : ∀ n {Γ′ σ τ ρ′} vtv {v} {vs : SVal Γ (σ ⇒ τ)} {vt : SVal Γ σ} {t : Term (σ • Γ′) τ} →
      ρ ⊢ val vs ↓[ i 0 ] closure t ρ′ →
      ρ ⊢ val vt ↓[ i 0 ] vtv →
      (vtv • ρ′) ⊢ t ↓[ i n ] v →
      ρ ⊢ app vs vt ↓[ i (suc n) ] v
    lett :
      ∀ n1 n2 {σ τ} vsv {v} (s : Term Γ σ) (t : Term (σ • Γ) τ) →
      ρ ⊢ s ↓[ i n1 ] vsv →
      (vsv • ρ) ⊢ t ↓[ i n2 ] v →
      ρ ⊢ lett s t ↓[ i (suc n1 + n2) ] v
    lit : ∀ n →
      ρ ⊢ const (lit n) ↓[ i 0 ] natV n

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context DType as DC

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ nat = nat

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δτ τ • ΔΔ Γ
--ΔΔ Γ = Γ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var (ΔΔ Δ) (Δτ τ)) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  -- constants aka. primitives
  dconst :
    (c : Const τ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ

derive-dsval : ∀ {Δ σ} → (t : SVal Δ σ) → DSVal Δ σ
derive-dsval (var x) = dvar (derive-dvar x)

derive-dsval (abs t) = dabs (derive-dterm t)

derive-dterm (val x) = dval (derive-dsval x)
derive-dterm (const c) = dconst c
derive-dterm (app vs vt) = dapp (derive-dsval vs) vt (derive-dsval vt)
derive-dterm (lett s t) = dlett s (derive-dterm s) (derive-dterm t)

data DVal : Type → Set
import Base.Denotation.Environment DType DVal as D

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = D.⟦ Δ ⟧Context

data DVal where
  dclosure : ∀ {Γ σ τ} → (dt : DTerm (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) →  (dρ : ChΔ Γ) → DVal (σ ⇒ τ)
  dnatV : ∀ (n : ℕ) → DVal nat

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : ∀ {τ} → DTerm Γ τ → DVal τ → Set where
  dabs : ∀ {σ τ} {dt : DTerm (σ • Γ) τ} →
    ρ D dρ ⊢ dval (dabs dt) ↓ dclosure dt ρ dρ
  dvar : ∀ {τ} (x : DC.Var Γ τ) →
    ρ D dρ ⊢ dval (dvar (derive-dvar x)) ↓ D.⟦ x ⟧Var dρ
  dlit : ∀ n →
    ρ D dρ ⊢ dconst (lit n) ↓ dnatV 0
  dapp : ∀ {hasIdx} {n : Idx hasIdx}
    {Γ′ σ τ ρ′ dρ′} {vtv} {dv}
    {dvs : DSVal Γ (σ ⇒ τ)}
    {vt : SVal Γ σ} {dvt : DSVal Γ σ}
    {dvtv} {dt : DTerm (σ • Γ′) τ} →
    ρ D dρ ⊢ dval dvs ↓ dclosure dt ρ′ dρ′ →
    ρ ⊢ val vt ↓[ n ] vtv →
    ρ D dρ ⊢ dval dvt ↓ dvtv →
    (vtv • ρ′) D (dvtv • dρ′) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dapp dvs vt dvt ↓ dv
  dlett : ∀ {hasIdx} {n : Idx hasIdx}
    {σ τ} {s : Term Γ σ} {ds} {dt : DTerm (σ • Γ) τ}
    {vsv dvsv dv} →
    ρ ⊢ s ↓[ n ] vsv →
    ρ D dρ ⊢ ds ↓ dvsv →
    (vsv • ρ) D (dvsv • dρ) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dlett s ds dt ↓ dv

mutual
  rrelT3 : ∀ {τ Γ} (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  rrelT3 {τ} t1 dt t2 ρ1 dρ ρ2 k =
    (v1 v2 : Val τ) →
    ∀ j (j<k : j < k) →
    (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t1 ↓[ i' j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t2 ↓[ no ] v2) →
    Σ[ dv ∈ DVal τ ]
    ρ1 D dρ ⊢ dt ↓ dv ×
    rrelV3 τ v1 dv v2 (k ∸ j)

  rrelV3 : ∀ τ (v1 : Val τ) (dv : DVal τ) (v2 : Val τ) → ℕ → Set
  rrelV3 nat (natV v1) (dnatV dv) (natV v2) n = dv + v1 ≡ v2
  rrelV3 (σ ⇒ τ) (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ dρ) (closure {Γ2} t2 ρ2) n =
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ρ1 ≡ ρ ×
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        rrelV3 σ v1 dv v2 k →
        rrelT3
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
          k
      }

rrelρ3 : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
rrelρ3 ∅ ∅ ∅ ∅ n = ⊤
rrelρ3 (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) n = rrelV3 τ v1 dv v2 n × rrelρ3 Γ ρ1 dρ ρ2 n

rrelV3-mono : ∀ m n → m ≤ n → ∀ τ v1 dv v2 → rrelV3 τ v1 dv v2 n → rrelV3 τ v1 dv v2 m
rrelV3-mono m n m≤n (σ ⇒ τ) (closure t ρ) (dclosure dt ρ₁ dρ) (closure t₁ ρ₂) ((refl , refl) , refl , vv) = (refl  , refl) , refl , λ k k<m → vv k (≤-trans k<m m≤n)
rrelV3-mono m n m≤n nat (natV n₁) (dnatV n₂) (natV n₃) vv = vv

rrelρ3-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → rrelρ3 Γ ρ1 dρ ρ2 m
rrelρ3-mono m n m≤n ∅ ∅ ∅ ∅ tt = tt
rrelρ3-mono m n m≤n (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) = rrelV3-mono m n m≤n _ v1 dv v2 vv , rrelρ3-mono m n m≤n Γ ρ1 dρ ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

⟦_⟧RelVar3 : ∀ {Γ τ n} (x : Var Γ τ) {ρ1 dρ ρ2} →
  rrelρ3 Γ ρ1 dρ ρ2 n →
  rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
⟦ this ⟧RelVar3   {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = vv
⟦ that x ⟧RelVar3 {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = ⟦ x ⟧RelVar3 ρρ

rfundamentalV3 : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelT3 (val (var x)) (dval (dvar (derive-dvar x))) (val (var x)) ρ1 dρ ρ2 n
rfundamentalV3 x n ρ1 dρ ρ2 ρρ .(⟦ x ⟧Var ρ1) .(⟦ x ⟧Var ρ2) .0 j<n (var .x) (var .x) = (D.⟦ x ⟧Var dρ) , dvar x , ⟦ x ⟧RelVar3 ρρ

m∸n≤m : ∀ m n → m ∸ n ≤ m
m∸n≤m m zero = ≤-refl
m∸n≤m zero (suc n) = z≤n
m∸n≤m (suc m) (suc n) = ≤-step (m∸n≤m m n)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

sub∸ : ∀ m n o → m + n ≤ o → n ≤ o ∸ m
sub∸ m n o n+m≤o rewrite +-comm m n | cong (_≤ o ∸ m) (sym (m+n∸n≡m n m)) = ∸-mono n+m≤o (≤-refl {m})

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k
rfundamental3 k (val (var x)) ρ1 dρ ρ2 ρρ = rfundamentalV3 x k ρ1 dρ ρ2 ρρ
rfundamental3 (suc k) (val (abs t)) ρ1 dρ ρ2 ρρ .(closure t ρ1) .(closure t ρ2) .0 (s≤s j<k) abs abs =
  dclosure (derive-dterm t) ρ1 dρ , dabs , (refl , refl) , refl ,
    λ k₁ k<n v1 dv v2 vv v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 →
    rfundamental3 k₁ t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv ,  rrelρ3-mono k₁ (suc k) (lt1 k<n) _ _ _ _ ρρ) v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
rfundamental3 k (const .(lit n)) ρ1 dρ ρ2 ρρ (natV n) .(natV n) .0 j<k (lit .n) (lit .n) = dnatV 0 , dlit n , refl
rfundamental3 (suc k) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s j<k)
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app _ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc k) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
  | rfundamental3 (suc k) (val vt) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , dsvv | dtv , vt↓dvv , dtvv
  with dsvv k (s≤s ≤-refl) vtv1 dtv vtv2 (rrelV3-mono k (suc k) (≤-step ≤-refl) _ _ _ _ dtvv) v1 v2 j j<k ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv = dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv
rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ _ _ _ dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl

-- Step-indexed logical relations based on relational big-step semantics
-- for ILC-based incremental computation.

-- Goal: prove the fundamental lemma for a ternary logical relation (change
-- validity) across t1, dt and t2. The fundamnetal lemma relates t, derive t and
-- t. That is, we relate a term evaluated relative to an original environment,
-- its derivative evaluated relative to a valid environment change, and the
-- original term evaluated relative to an updated environment.
--
-- Missing goal: here ⊕ isn't defined and wouldn't yet agree with change
-- validity.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, including the choice of using ANF syntax
-- to simplify some step-indexing proofs.
--
-- In fact, this development is typed, hence some parts of the model are closer
-- to Ahmed (ESOP 2006), "Step-Indexed Syntactic Logical Relations for Recursive
-- and Quantified Types". But for many relevant aspects, the two papers are
-- very similar. In fact, I first defined similar logical relations
-- without types, but they require a trickier recursion scheme for well-founded
-- recursion, and I failed to do any proof in that setting.
--
-- The original inspiration came from Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but we ended up looking
-- at their source.
--
-- The main insight from the ISAC paper missing from the other one is how to
-- step-index a big-step semantics correctly: just ensure that the steps in the
-- big-step semantics agree with the ones in the small-step semantics. *Then*
-- everything just works with big-step semantics. Quite a few other details are
-- fiddly, but those are the same in small-step semantics.
--
-- The crucial novelty here is that we relate two computations on different
-- inputs. So we only conclude their results are related if both terminate; the
-- relation for computations does not prove that if the first computation
-- terminates, then the second terminates as well.
--
-- Instead, e1, de and e2 are related at k steps if, whenever e1 terminates in j
-- < k steps and e2 terminates with any step count, then de terminates (with any
-- step count) and their results are related at k - j steps.
--
-- Even when e1 terminates in j steps implies that e2 terminates, e2 gets no
-- bound. Similarly, we do not bound in how many steps de terminates, since on
-- big inputs it might take long.

module Thesis.StepIndexedRelBigStepTypedAnfIlcCorrect where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type
infixr 20 _⇒_

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) (τ : Type) : Set
-- Source values
data SVal (Γ : Context) : (τ : Type) → Set where
  var : ∀ {τ} →
    (x : Var Γ τ) →
    SVal Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    SVal Γ (σ ⇒ τ)
data Term (Γ : Context) (τ : Type) where
  val :
    SVal Γ τ →
    Term Γ τ
  -- constants aka. primitives
  const :
    (c : Const τ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  app : ∀ {σ}
    (vs : SVal Γ (σ ⇒ τ)) →
    (vt : SVal Γ σ) →
    Term Γ τ
  lett : ∀ {σ}
    (s : Term Γ σ) →
    (t : Term (σ • Γ) τ) →
    Term Γ τ

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  natV : ∀ (n : ℕ) → Val nat

import Data.Integer as I
open I using (ℤ)

-- Yann's idea.
data HasIdx : Set where
  true : HasIdx
  false : HasIdx
data Idx : HasIdx → Set where
  i' : ℕ → Idx true
  no : Idx false

i : {hasIdx : HasIdx} → ℕ → Idx hasIdx
i {false} j = no
i {true} j = i' j

module _ {hasIdx : HasIdx} where
  data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : ∀ {τ} → Term Γ τ → Idx hasIdx → Val τ → Set where
    abs : ∀ {σ τ} {t : Term (σ • Γ) τ} →
      ρ ⊢ val (abs t) ↓[ i 0 ] closure t ρ
    var : ∀ {τ} (x : Var Γ τ) →
      ρ ⊢ val (var x) ↓[ i 0 ] (⟦ x ⟧Var ρ)
    app : ∀ n {Γ′ σ τ ρ′} vtv {v} {vs : SVal Γ (σ ⇒ τ)} {vt : SVal Γ σ} {t : Term (σ • Γ′) τ} →
      ρ ⊢ val vs ↓[ i 0 ] closure t ρ′ →
      ρ ⊢ val vt ↓[ i 0 ] vtv →
      (vtv • ρ′) ⊢ t ↓[ i n ] v →
      ρ ⊢ app vs vt ↓[ i (suc n) ] v
    lett :
      ∀ n1 n2 {σ τ} vsv {v} (s : Term Γ σ) (t : Term (σ • Γ) τ) →
      ρ ⊢ s ↓[ i n1 ] vsv →
      (vsv • ρ) ⊢ t ↓[ i n2 ] v →
      ρ ⊢ lett s t ↓[ i (suc n1 + n2) ] v
    lit : ∀ n →
      ρ ⊢ const (lit n) ↓[ i 0 ] natV n

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context DType as DC

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ nat = nat

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δτ τ • ΔΔ Γ
--ΔΔ Γ = Γ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var (ΔΔ Δ) (Δτ τ)) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  -- constants aka. primitives
  dconst :
    (c : Const τ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ

derive-dsval : ∀ {Δ σ} → (t : SVal Δ σ) → DSVal Δ σ
derive-dsval (var x) = dvar (derive-dvar x)

derive-dsval (abs t) = dabs (derive-dterm t)

derive-dterm (val x) = dval (derive-dsval x)
derive-dterm (const c) = dconst c
derive-dterm (app vs vt) = dapp (derive-dsval vs) vt (derive-dsval vt)
derive-dterm (lett s t) = dlett s (derive-dterm s) (derive-dterm t)

data DVal : Type → Set
import Base.Denotation.Environment DType DVal as D

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = D.⟦ Δ ⟧Context

data DVal where
  dclosure : ∀ {Γ σ τ} → (dt : DTerm (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) →  (dρ : ChΔ Γ) → DVal (σ ⇒ τ)
  dnatV : ∀ (n : ℕ) → DVal nat

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : ∀ {τ} → DTerm Γ τ → DVal τ → Set where
  dabs : ∀ {σ τ} {dt : DTerm (σ • Γ) τ} →
    ρ D dρ ⊢ dval (dabs dt) ↓ dclosure dt ρ dρ
  dvar : ∀ {τ} (x : DC.Var Γ τ) →
    ρ D dρ ⊢ dval (dvar (derive-dvar x)) ↓ D.⟦ x ⟧Var dρ
  dlit : ∀ n →
    ρ D dρ ⊢ dconst (lit n) ↓ dnatV 0
  dapp : ∀ {hasIdx} {n : Idx hasIdx}
    {Γ′ σ τ ρ′ dρ′} {vtv} {dv}
    {dvs : DSVal Γ (σ ⇒ τ)}
    {vt : SVal Γ σ} {dvt : DSVal Γ σ}
    {dvtv} {dt : DTerm (σ • Γ′) τ} →
    ρ D dρ ⊢ dval dvs ↓ dclosure dt ρ′ dρ′ →
    ρ ⊢ val vt ↓[ n ] vtv →
    ρ D dρ ⊢ dval dvt ↓ dvtv →
    (vtv • ρ′) D (dvtv • dρ′) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dapp dvs vt dvt ↓ dv
  dlett : ∀ {hasIdx} {n : Idx hasIdx}
    {σ τ} {s : Term Γ σ} {ds} {dt : DTerm (σ • Γ) τ}
    {vsv dvsv dv} →
    ρ ⊢ s ↓[ n ] vsv →
    ρ D dρ ⊢ ds ↓ dvsv →
    (vsv • ρ) D (dvsv • dρ) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dlett s ds dt ↓ dv

mutual
  -- Note the appearance of ρ. I think that's odd but I'm confused.
  rrelT3 : ∀ {τ Γ} (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ) (ρ1 ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  rrelT3 {τ} t1 dt t2 ρ1 ρ dρ ρ2 k =
    (v1 v2 : Val τ) →
    ∀ j (j<k : j < k) →
    (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t1 ↓[ i' j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t2 ↓[ no ] v2) →
    Σ[ dv ∈ DVal τ ]
    ρ D dρ ⊢ dt ↓ dv ×
    rrelV3 τ v1 dv v2 (k ∸ j)

  rrelV3 : ∀ τ (v1 : Val τ) (dv : DVal τ) (v2 : Val τ) → ℕ → Set
  rrelV3 nat (natV v1) (dnatV dv) (natV v2) n = dv + v1 ≡ v2
  rrelV3 (σ ⇒ τ) (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ dρ) (closure {Γ2} t2 ρ2) n =
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        rrelV3 σ v1 dv v2 k →
        rrelT3
          t1
          dt
          t2
          (v1 • ρ1)
          (v1 • ρ)
          (dv • dρ)
          (v2 • ρ2)
          k
      }

rrelρ3 : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
rrelρ3 ∅ ∅ ∅ ∅ n = ⊤
rrelρ3 (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) n = rrelV3 τ v1 dv v2 n × rrelρ3 Γ ρ1 dρ ρ2 n

rrelV3-mono : ∀ m n → m ≤ n → ∀ τ v1 dv v2 → rrelV3 τ v1 dv v2 n → rrelV3 τ v1 dv v2 m
rrelV3-mono m n m≤n (σ ⇒ τ) (closure t ρ) (dclosure dt ρ₁ dρ) (closure t₁ ρ₂) ((refl , refl) , vv) = (refl  , refl) , λ k k<m → vv k (≤-trans k<m m≤n)
rrelV3-mono m n m≤n nat (natV n₁) (dnatV n₂) (natV n₃) vv = vv

rrelρ3-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → rrelρ3 Γ ρ1 dρ ρ2 m
rrelρ3-mono m n m≤n ∅ ∅ ∅ ∅ tt = tt
rrelρ3-mono m n m≤n (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) = rrelV3-mono m n m≤n _ v1 dv v2 vv , rrelρ3-mono m n m≤n Γ ρ1 dρ ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

⟦_⟧RelVar3 : ∀ {Γ τ n} (x : Var Γ τ) {ρ1 dρ ρ2} →
  rrelρ3 Γ ρ1 dρ ρ2 n →
  rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
⟦ this ⟧RelVar3   {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = vv
⟦ that x ⟧RelVar3 {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = ⟦ x ⟧RelVar3 ρρ

rfundamentalV3 : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelT3 (val (var x)) (dval (dvar (derive-dvar x))) (val (var x)) ρ1 ρ1 dρ ρ2 n
rfundamentalV3 x n ρ1 dρ ρ2 ρρ .(⟦ x ⟧Var ρ1) .(⟦ x ⟧Var ρ2) .0 j<n (var .x) (var .x) = (D.⟦ x ⟧Var dρ) , dvar x , ⟦ x ⟧RelVar3 ρρ

m∸n≤m : ∀ m n → m ∸ n ≤ m
m∸n≤m m zero = ≤-refl
m∸n≤m zero (suc n) = z≤n
m∸n≤m (suc m) (suc n) = ≤-step (m∸n≤m m n)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

sub∸ : ∀ m n o → m + n ≤ o → n ≤ o ∸ m
sub∸ m n o n+m≤o rewrite +-comm m n | cong (_≤ o ∸ m) (sym (m+n∸n≡m n m)) = ∸-mono n+m≤o (≤-refl {m})

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 ρ1 dρ ρ2 k
rfundamental3 k (val (var x)) ρ1 dρ ρ2 ρρ = rfundamentalV3 x k ρ1 dρ ρ2 ρρ
rfundamental3 (suc k) (val (abs t)) ρ1 dρ ρ2 ρρ .(closure t ρ1) .(closure t ρ2) .0 (s≤s j<k) abs abs =
  dclosure (derive-dterm t) ρ1 dρ , dabs , (refl , refl) ,
    λ k₁ k<n v1 dv v2 vv v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 →
    rfundamental3 k₁ t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv ,  rrelρ3-mono k₁ (suc k) (lt1 k<n) _ _ _ _ ρρ) v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
rfundamental3 k (const .(lit n)) ρ1 dρ ρ2 ρρ (natV n) .(natV n) .0 j<k (lit .n) (lit .n) = dnatV 0 , dlit n , refl
rfundamental3 (suc k) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s j<k)
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app _ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc k) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
  | rfundamental3 (suc k) (val vt) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , dsvv | dtv , vt↓dvv , dtvv
  with dsvv k (s≤s ≤-refl) vtv1 dtv vtv2 (rrelV3-mono k (suc k) (≤-step ≤-refl) _ _ _ _ dtvv) v1 v2 j j<k ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv = dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv
rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ _ _ _ dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl


IND-CCA2: re-export Game.CCA-Common

IND-CCA2: re-export Game.CCA-Common

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

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.Unit

open import Data.Nat.NP
--open import Rat

open import Explore.Type
open import Explore.Explorable
open import Explore.Product
open Operators
open import Relation.Binary.PropositionalEquality

module Game.IND-CCA2
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where
open import Game.CCA-Common Message CipherText public

Adv : ★
Adv = Rₐ → PubKey → Strategy ((Message × Message) × (CipherText → Strategy Bit))

{-
Valid-Adv : Adv → Set
Valid-Adv adv = ∀ {rₐ rₓ pk c} → Valid (λ x → x ≢ c) {!!}
-}

R : ★
R = Rₐ × Rₖ × Rₑ

Game : ★
Game = Adv → R → Bit

⅁ : Bit → Game
⅁ b m (rₐ , rₖ , rₑ) with KeyGen rₖ
... | pk , sk = b′ where
  open Eval Dec sk

  ev = eval (m rₐ pk)
  mb = proj (proj₁ ev) b
  d = proj₂ ev

  c  = Enc pk mb rₑ
  b′ = eval (d c)

module Advantage
  (μₑ : Explore₀ Rₑ)
  (μₖ : Explore₀ Rₖ)
  (μₐ : Explore₀ Rₐ)
  where
  μR : Explore₀ R
  μR = μₐ ×ᵉ μₖ ×ᵉ μₑ

  module μR = FromExplore₀ μR

  run : Bit → Adv → ℕ
  run b adv = μR.count (⅁ b adv)

  Advantage : Adv → ℕ
  Advantage adv = dist (run 0b adv) (run 1b adv)

  --Advantageℚ : Adv → ℚ
  --Advantageℚ adv = Advantage adv / μR.Card

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

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

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.Unit

open import Data.Nat.NP
--open import Rat

open import Explore.Type
open import Explore.Explorable
open import Explore.Product
open Operators
open import Relation.Binary.PropositionalEquality

module Game.IND-CCA2
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where
open import Game.CCA-Common Message CipherText

Adv : ★
Adv = Rₐ → PubKey → Strategy ((Message × Message) × (CipherText → Strategy Bit))

{-
Valid-Adv : Adv → Set
Valid-Adv adv = ∀ {rₐ rₓ pk c} → Valid (λ x → x ≢ c) {!!}
-}

R : ★
R = Rₐ × Rₖ × Rₑ

Game : ★
Game = Adv → R → Bit

⅁ : Bit → Game
⅁ b m (rₐ , rₖ , rₑ) with KeyGen rₖ
... | pk , sk = b′ where
  open Eval Dec sk

  ev = eval (m rₐ pk)
  mb = proj (proj₁ ev) b
  d = proj₂ ev

  c  = Enc pk mb rₑ
  b′ = eval (d c)

module Advantage
  (μₑ : Explore₀ Rₑ)
  (μₖ : Explore₀ Rₖ)
  (μₐ : Explore₀ Rₐ)
  where
  μR : Explore₀ R
  μR = μₐ ×ᵉ μₖ ×ᵉ μₑ

  module μR = FromExplore₀ μR

  run : Bit → Adv → ℕ
  run b adv = μR.count (⅁ b adv)

  Advantage : Adv → ℕ
  Advantage adv = dist (run 0b adv) (run 1b adv)

  --Advantageℚ : Adv → ℚ
  --Advantageℚ adv = Advantage adv / μR.Card

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


Fixed doc.

Fixed doc.

------------------------------------------------------------------------------
-- From ListP as the least fixed-point to ListP using data
------------------------------------------------------------------------------

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

-- We want to represent the polymorphic total lists data type
--
-- data ListP (A : D → Set) : D → Set where
--   lnil  : ListP A []
--   lcons : ∀ {x xs} → A x → ListP A xs → ListP A (x ∷ xs)
--
-- using the representation of ListP as the least fixed-point.

module LeastFixedPoints.ListP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Nat.Type
open import FOTC.Data.Nat.UnaryNumbers

------------------------------------------------------------------------------
-- ListP is a least fixed-point of a functor

-- The functor.
-- ListPF : (D → Set) → (D → Set) → D → Set
-- ListPF A B xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ B xs' ∧ xs ≡ x' ∷ xs')

-- ListP is the least fixed-point of ListPF.
postulate
  ListP : (D → Set) → D → Set

  -- ListP is a pre-fixed point of ListPF.
  --
  -- Peter: It corresponds to the introduction rules.
  ListP-in :
    (A : D → Set) →
    ∀ {xs} → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ ListP A xs' ∧ xs ≡ x' ∷ xs') →
    ListP A xs

  -- ListP is the least pre-fixed point of ListPF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  ListP-ind :
    (A B : D → Set) →
    (∀ {xs} → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ B xs' ∧ xs ≡ x' ∷ xs') → B xs) →
    ∀ {xs} → ListP A xs → B xs

------------------------------------------------------------------------------
-- The data constructors of ListP.
lnil  : (A : D → Set) → ListP A []
lnil A = ListP-in A (inj₁ refl)

lcons : (A : D → Set) → ∀ {x xs} → A x → ListP A xs → ListP A (x ∷ xs)
lcons A {n} {ns} An LPns = ListP-in A (inj₂ (n , ns , An , LPns , refl))

------------------------------------------------------------------------------
-- The induction principle for ListP.
indListP : (A B : D → Set) →
           B [] →
           (∀ x {xs} → A x → B xs → B (x ∷ xs)) →
           ∀ {xs} → ListP A xs → B xs
indListP A B B[] is = ListP-ind A B h
  where
  h : ∀ {xs} →
      xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ B xs' ∧ xs ≡ x' ∷ xs') →
      B xs
  h (inj₁ xs≡[])                        = subst B (sym xs≡[]) B[]
  h (inj₂ (x' , xs' , Ax' , Bxs' , h₁)) = subst B (sym h₁) (is x' Ax' Bxs')

------------------------------------------------------------------------------
-- Examples

-- "Heterogeneous" total lists
xs : D
xs = [0] ∷ true ∷ [1] ∷ false ∷ []

List : D → Set
List = ListP (λ d → d ≡ d)

xs-ListP : List xs
xs-ListP =
  lcons A refl (lcons A refl (lcons A refl (lcons A refl (lnil A))))
  where
  A : D → Set
  A d = d ≡ d

-- Total lists of total natural numbers
ys : D
ys = [0] ∷ [1] ∷ [2] ∷ []

ListN : D → Set
ListN = ListP N

ys-ListP : ListN ys
ys-ListP =
  lcons N nzero (lcons N (nsucc nzero) (lcons N (nsucc (nsucc nzero)) (lnil N)))

------------------------------------------------------------------------------
-- From ListP as the least fixed-point to ListP using data
------------------------------------------------------------------------------

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

-- We want to represent the polymorphic total lists data type
--
-- data ListP (A : D → Set) : D → Set₁ where
--   lnil  : ListP A []
--   lcons : ∀ {x xs} → A x → ListP A xs → ListP A (x ∷ xs)
--
-- using the representation of ListP as the least fixed-point.

module LeastFixedPoints.ListP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Nat.Type
open import FOTC.Data.Nat.UnaryNumbers

------------------------------------------------------------------------------
-- ListP is a least fixed-point of a functor

-- The functor.
-- ListPF : (D → Set) → (D → Set) → D → Set
-- ListPF A B xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ B xs' ∧ xs ≡ x' ∷ xs')

-- ListP is the least fixed-point of ListPF.
postulate
  ListP : (D → Set) → D → Set

  -- ListP is a pre-fixed point of ListPF.
  --
  -- Peter: It corresponds to the introduction rules.
  ListP-in :
    (A : D → Set) →
    ∀ {xs} → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ ListP A xs' ∧ xs ≡ x' ∷ xs') →
    ListP A xs

  -- ListP is the least pre-fixed point of ListPF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  ListP-ind :
    (A B : D → Set) →
    (∀ {xs} → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ B xs' ∧ xs ≡ x' ∷ xs') → B xs) →
    ∀ {xs} → ListP A xs → B xs

------------------------------------------------------------------------------
-- The data constructors of ListP.
lnil  : (A : D → Set) → ListP A []
lnil A = ListP-in A (inj₁ refl)

lcons : (A : D → Set) → ∀ {x xs} → A x → ListP A xs → ListP A (x ∷ xs)
lcons A {n} {ns} An LPns = ListP-in A (inj₂ (n , ns , An , LPns , refl))

------------------------------------------------------------------------------
-- The induction principle for ListP.
indListP : (A B : D → Set) →
           B [] →
           (∀ x {xs} → A x → B xs → B (x ∷ xs)) →
           ∀ {xs} → ListP A xs → B xs
indListP A B B[] is = ListP-ind A B h
  where
  h : ∀ {xs} →
      xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] A x' ∧ B xs' ∧ xs ≡ x' ∷ xs') →
      B xs
  h (inj₁ xs≡[])                        = subst B (sym xs≡[]) B[]
  h (inj₂ (x' , xs' , Ax' , Bxs' , h₁)) = subst B (sym h₁) (is x' Ax' Bxs')

------------------------------------------------------------------------------
-- Examples

-- "Heterogeneous" total lists
xs : D
xs = [0] ∷ true ∷ [1] ∷ false ∷ []

List : D → Set
List = ListP (λ d → d ≡ d)

xs-ListP : List xs
xs-ListP =
  lcons A refl (lcons A refl (lcons A refl (lcons A refl (lnil A))))
  where
  A : D → Set
  A d = d ≡ d

-- Total lists of total natural numbers
ys : D
ys = [0] ∷ [1] ∷ [2] ∷ []

ListN : D → Set
ListN = ListP N

ys-ListP : ListN ys
ys-ListP =
  lcons N nzero (lcons N (nsucc nzero) (lcons N (nsucc (nsucc nzero)) (lnil N)))