Bits: use patterns 0∷ and 1∷

Bits: use patterns 0∷ and 1∷

{-# OPTIONS --without-K #-}
module Data.Bits where

open import Algebra
open import Level.NP
open import Type hiding (★)
open import Data.Nat.NP hiding (_==_) renaming (_<=_ to _ℕ<=_)
open import Data.Bit using (Bit)
open import Data.Two renaming (_==_ to _==ᵇ_)
open import Data.Fin.NP using (Fin; zero; suc; inject₁; inject+; raise; Fin▹ℕ)
open import Data.Vec.NP
open import Function.NP
import Data.List.NP as L

-- Re-export some vector functions, maybe they should be given
-- less generic types.
open Data.Vec.NP public using ([]; _∷_; _++_; head; tail; map; replicate; RewireTbl; rewire; rewireTbl; onᵢ)

Bits : ℕ → ★₀
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → ★₀
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0₂

-- Notice that all empty vectors are the same, hence 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1₂

pattern 0∷_ xs = 0₂ ∷ xs
pattern 1∷_ xs = 1₂ ∷ xs
{-
0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0₂ ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1₂ ∷ xs
-}

_!_ : ∀ {a n} {A : ★ a} → Vec A n → Fin n → A
_!_ = flip lookup

-- see Data.Bits.Properties
_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bit
[]         == []         = 1₂
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

_<=_ : ∀ {n} (xs ys : Bits n) → Bit
[]        <= []        = 1₂
(1₂ ∷ xs) <= (0₂ ∷ ys) = 0₂
(0₂ ∷ xs) <= (1₂ ∷ ys) = 1₂
(_  ∷ xs) <= (_  ∷ ys) = xs <= ys

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

⊕-group : ℕ → Group ₀ ₀
⊕-group = LiftGroup.group Xor°.+-group

module ⊕-Group  (n : ℕ) = Group (⊕-group n)
module ⊕-Monoid (n : ℕ) = Monoid (⊕-Group.monoid n)

-- Negate all bits, i.e. "xor"ing them by one.
vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

-- Negate the i-th bit.
notᵢ : ∀ {n} (i : Fin n) → Bits n → Bits n
notᵢ = onᵢ not

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ k {n} → Bits (n + k) → Bits k
lsb _ {n} = drop n

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0∷ bs) = inject₁ (#1 bs)
#1 (1∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ map not

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM (toList (0∷ 1∷ []))
  where open L.Monad

allBits : ∀ n → Vec (Bits n) (2^ n)
allBits zero    = [] ∷ []
allBits (suc n) = map 0∷_ bs ++ map 1∷_ bs
  where bs = allBits n

always : ∀ n → Bits n → Bit
always _ _ = 1₂

never  : ∀ n → Bits n → Bit
never _ _ = 0₂

_∨°_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_∨°_ f g x = f x ∨ g x

_∧°_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_∧°_ f g x = f x ∧ g x

not° : ∀ {n} (f : Bits n → Bit) → Bits n → Bit
not° f = not ∘ f

view∷ : ∀ {n a b} {A : ★ a} {B : ★ b} → (A → Vec A n → B) → Vec A (suc n) → B
view∷ f (x ∷ xs) = f x xs

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry []      = 0∷ []
sucBCarry (0∷ xs) = 0∷ sucBCarry xs
sucBCarry (1∷ xs) = view∷ (λ x xs → x ∷ not x ∷ xs) (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

--_[mod_] : ℕ → ℕ → ★₀
--a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0∷ xs) = 1∷ xs
  sucRB (1∷ xs) = 0∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2^ n)
toFin         []      = zero
toFin         (0∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1∷ xs) = raise (2^ n) (toFin xs)

Bits▹ℕ : ∀ {n} → Bits n → ℕ
Bits▹ℕ         []      = zero
Bits▹ℕ         (0∷ xs) = Bits▹ℕ xs
Bits▹ℕ {suc n} (1∷ xs) = 2^ n + Bits▹ℕ xs

ℕ▹Bits : ∀ {n} → ℕ → Bits n
ℕ▹Bits {zero}  _ = []
ℕ▹Bits {suc n} x = [0: 0∷ ℕ▹Bits x
                    1: 1∷ ℕ▹Bits (x ∸ 2^ n)
                   ]′ (2^ n ℕ<= x)

ℕ▹Bits′ : ∀ {n} → ℕ → Bits n
ℕ▹Bits′ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2^ n) → Bits n
fromFin = ℕ▹Bits ∘ Fin▹ℕ

lookupTbl : ∀ {n a} {A : ★ a} → Bits n → Vec A (2^ n) → A
lookupTbl         []       = head
lookupTbl         (0∷ key) = lookupTbl key ∘ take _
lookupTbl {suc n} (1∷ key) = lookupTbl key ∘ drop (2^ n)

funFromTbl : ∀ {n a} {A : ★ a} → Vec A (2^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : ★ a} → (Bits n → A) → Vec A (2^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero}  f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_)
                    ++ tblFromFun {n} (f ∘ 1∷_)

{-# OPTIONS --without-K #-}
module Data.Bits where

open import Algebra
open import Level.NP
open import Type hiding (★)
open import Data.Nat.NP hiding (_==_) renaming (_<=_ to _ℕ<=_)
open import Data.Bit using (Bit)
open import Data.Two renaming (_==_ to _==ᵇ_)
open import Data.Fin.NP using (Fin; zero; suc; inject₁; inject+; raise; Fin▹ℕ)
open import Data.Vec.NP
open import Function.NP
import Data.List.NP as L

-- Re-export some vector functions, maybe they should be given
-- less generic types.
open Data.Vec.NP public using ([]; _∷_; _++_; head; tail; map; replicate; RewireTbl; rewire; rewireTbl; onᵢ)

Bits : ℕ → ★₀
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → ★₀
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0₂

-- Notice that all empty vectors are the same, hence 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1₂

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0₂ ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1₂ ∷ xs

_!_ : ∀ {a n} {A : ★ a} → Vec A n → Fin n → A
_!_ = flip lookup

-- see Data.Bits.Properties
_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bit
[]         == []         = 1₂
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

_<=_ : ∀ {n} (xs ys : Bits n) → Bit
[]        <= []        = 1₂
(1₂ ∷ xs) <= (0₂ ∷ ys) = 0₂
(0₂ ∷ xs) <= (1₂ ∷ ys) = 1₂
(_  ∷ xs) <= (_  ∷ ys) = xs <= ys

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

⊕-group : ℕ → Group ₀ ₀
⊕-group = LiftGroup.group Xor°.+-group

module ⊕-Group  (n : ℕ) = Group (⊕-group n)
module ⊕-Monoid (n : ℕ) = Monoid (⊕-Group.monoid n)

-- Negate all bits, i.e. "xor"ing them by one.
vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

-- Negate the i-th bit.
notᵢ : ∀ {n} (i : Fin n) → Bits n → Bits n
notᵢ = onᵢ not

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ k {n} → Bits (n + k) → Bits k
lsb _ {n} = drop n

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0₂ ∷ bs) = inject₁ (#1 bs)
#1 (1₂ ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ map not

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM (toList (0₂ ∷ 1₂ ∷ []))
  where open L.Monad

allBits : ∀ n → Vec (Bits n) (2^ n)
allBits zero    = [] ∷ []
allBits (suc n) = map 0∷_ bs ++ map 1∷_ bs
  where bs = allBits n

always : ∀ n → Bits n → Bit
always _ _ = 1₂

never  : ∀ n → Bits n → Bit
never _ _ = 0₂

_∨°_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_∨°_ f g x = f x ∨ g x

_∧°_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_∧°_ f g x = f x ∧ g x

not° : ∀ {n} (f : Bits n → Bit) → Bits n → Bit
not° f = not ∘ f

view∷ : ∀ {n a b} {A : ★ a} {B : ★ b} → (A → Vec A n → B) → Vec A (suc n) → B
view∷ f (x ∷ xs) = f x xs

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry []        = 0₂ ∷ []
sucBCarry (0₂ ∷ xs) = 0₂ ∷ sucBCarry xs
sucBCarry (1₂ ∷ xs) = view∷ (λ x xs → x ∷ not x ∷ xs) (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

--_[mod_] : ℕ → ℕ → ★₀
--a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0₂ ∷ xs) = 1₂ ∷ xs
  sucRB (1₂ ∷ xs) = 0₂ ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2^ n)
toFin         []        = zero
toFin         (0₂ ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1₂ ∷ xs) = raise (2^ n) (toFin xs)

Bits▹ℕ : ∀ {n} → Bits n → ℕ
Bits▹ℕ         []        = zero
Bits▹ℕ         (0₂ ∷ xs) = Bits▹ℕ xs
Bits▹ℕ {suc n} (1₂ ∷ xs) = 2^ n + Bits▹ℕ xs

ℕ▹Bits : ∀ {n} → ℕ → Bits n
ℕ▹Bits {zero}  _ = []
ℕ▹Bits {suc n} x = [0: 0∷ ℕ▹Bits x
                    1: 1∷ ℕ▹Bits (x ∸ 2^ n)
                   ]′ (2^ n ℕ<= x)

ℕ▹Bits′ : ∀ {n} → ℕ → Bits n
ℕ▹Bits′ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2^ n) → Bits n
fromFin = ℕ▹Bits ∘ Fin▹ℕ

lookupTbl : ∀ {n a} {A : ★ a} → Bits n → Vec A (2^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0₂ ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1₂ ∷ key) tbl      = lookupTbl key (drop (2^ n) tbl)

funFromTbl : ∀ {n a} {A : ★ a} → Vec A (2^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : ★ a} → (Bits n → A) → Vec A (2^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero}  f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_)


switching args to implicit. another typo in theorem statement from copy and paste.

open import Nat
open import Prelude
open import List
open import core

module correspondence where
  mutual
    correspondence-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : dhexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Γ ⊢ e => τ
    correspondence-synth ESConst = SConst
    correspondence-synth (ESVar x₁) = SVar x₁
    correspondence-synth (ESLam ex) with correspondence-synth ex
    ... | ih = SLam {!!} ih
    correspondence-synth (ESAp1 x x₁ x₂ x₃) = {!!}
    correspondence-synth (ESAp2 x ex x₁ x₂) = {!!}
    correspondence-synth (ESAp3 x ex x₁) = {!!}
    correspondence-synth ESEHole = SEHole
    correspondence-synth (ESNEHole ex) = SNEHole (correspondence-synth ex)
    correspondence-synth (ESAsc1 x x₁) = {!!}
    correspondence-synth (ESAsc2 x) = {!!}

    correspondence-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : dhexp} {Δ : hctx}  →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          Γ ⊢ e <= τ
    correspondence-ana (EALam ex) with correspondence-ana ex
    ... | ih = ALam {!!} {!!} {!!}
    correspondence-ana (EASubsume x x₁ x₂ x₃) = {!!}
    correspondence-ana EAEHole = {!!}
    correspondence-ana (EANEHole x x₁) = {!!}

open import Nat
open import Prelude
open import List
open import core

module correspondence where
  mutual
    correspondence-synth : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Γ ⊢ e => τ
    correspondence-synth = {!!}

    correspondence-ana : (Γ : tctx) (e : hexp) (τ τ' : htyp) (d : dhexp) (Δ : hctx)  →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          Γ ⊢ e => τ
    correspondence-ana = {!!}


Minor changes.

Minor changes.

Ignore-this: 529ad8704ff72d3193f5542bb233c112

darcs-hash:20110206134114-3bd4e-f473ba69ce27325b4fc34ad80c7bf75310040ede.gz

------------------------------------------------------------------------------
-- Sort a list
------------------------------------------------------------------------------

-- This module define the program which sorts a list by converting it
-- into an ordered tree and then back to a list (Burstall, 1969, pp. 45-46).

-- R. M. Burstall. Proving properties of programs by structural
-- induction. The Computer Journal, 12(1):41–48, 1969.

module LTC.Program.SortList.SortList where

open import LTC.Base

open import LTC.Data.Bool using ( _&&_ )
open import LTC.Data.Nat.Inequalities using ( _≤_ )
open import LTC.Data.Nat.Type
  using ( N  -- The LTC natural numbers type.
        )
open import LTC.Data.List using ( _++_ )

------------------------------------------------------------------------------
-- Tree terms.
postulate
  nilTree  : D
  tip      : D → D
  node     : D → D → D → D

-- The tree type.
data Tree : D → Set where
  nilT  : Tree nilTree
  tipT  : ∀ {i} → N i → Tree (tip i)
  nodeT : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ → Tree (node t₁ i t₂)
{-# ATP hint nilT #-}
{-# ATP hint tipT #-}
{-# ATP hint nodeT #-}

------------------------------------------------------------------------------
-- Inequalites on lists and trees

-- Note from Burstall (p. 46): "The relation ≤ between lists is only an
-- ordering if nil is excluded, similarly for trees. This is untidy but
-- will not cause trouble."

postulate
  ≤-ItemList    : D → D → D
  ≤-ItemList-[] : ∀ item → ≤-ItemList item [] ≡ true
  ≤-ItemList-∷  : ∀ item i is →
                  ≤-ItemList item (i ∷ is) ≡ item ≤ i && ≤-ItemList item is
{-# ATP axiom ≤-ItemList-[] #-}
{-# ATP axiom ≤-ItemList-∷ #-}

LE-ItemList : D → D → Set
LE-ItemList item is = ≤-ItemList item is ≡ true
{-# ATP definition LE-ItemList #-}

postulate
  ≤-Lists    : D → D → D
  ≤-Lists-[] : ∀ is → ≤-Lists [] is ≡ true
  ≤-Lists-∷  : ∀ i is js →
               ≤-Lists (i ∷ is) js ≡ ≤-ItemList i js && ≤-Lists is js
{-# ATP axiom ≤-Lists-[] #-}
{-# ATP axiom ≤-Lists-∷ #-}

LE-Lists : D → D → Set
LE-Lists is js = ≤-Lists is js ≡ true
{-# ATP definition LE-Lists #-}

postulate
  ≤-ItemTree          : D → D → D
  ≤-ItemTree-nilTree  : ∀ item →   ≤-ItemTree item nilTree ≡ true
  ≤-ItemTree-tip      : ∀ item i → ≤-ItemTree item (tip i) ≡ item ≤ i
  ≤-ItemTree-node     : ∀ item t₁ i t₂ →
                          ≤-ItemTree item (node t₁ i t₂) ≡
                          ≤-ItemTree item t₁ && ≤-ItemTree item t₂
{-# ATP axiom ≤-ItemTree-nilTree #-}
{-# ATP axiom ≤-ItemTree-tip #-}
{-# ATP axiom ≤-ItemTree-node #-}

LE-ItemTree : D → D → Set
LE-ItemTree item t = ≤-ItemTree item t ≡ true
{-# ATP definition LE-ItemTree #-}

-- This function is not defined in the paper.
postulate
  ≤-TreeItem         : D → D → D
  ≤-TreeItem-nilTree : ∀ item →   ≤-TreeItem nilTree item ≡ true
  ≤-TreeItem-tip     : ∀ i item → ≤-TreeItem (tip i) item ≡ i ≤ item
  ≤-TreeItem-node    : ∀ t₁ i t₂ item →
                         ≤-TreeItem (node t₁ i t₂) item ≡
                         ≤-TreeItem t₁ item && ≤-TreeItem t₂ item
{-# ATP axiom ≤-TreeItem-nilTree #-}
{-# ATP axiom ≤-TreeItem-tip #-}
{-# ATP axiom ≤-TreeItem-node #-}

LE-TreeItem : D → D → Set
LE-TreeItem t item = ≤-TreeItem t item ≡ true
{-# ATP definition LE-TreeItem #-}

------------------------------------------------------------------------------
-- Auxiliary functions

postulate
  -- The foldr function with the last two args flipped.
  lit    : D → D → D → D
  lit-[] : ∀ (f : D) n →      lit f []       n ≡ n
  lit-∷  : ∀ (f : D) d ds n → lit f (d ∷ ds) n ≡ f · d · (lit f ds n)
{-# ATP axiom lit-[] #-}
{-# ATP axiom lit-∷ #-}

------------------------------------------------------------------------------
-- Ordering functions and predicates on lists and trees

postulate
  ordList    : D → D
  ordList-[] :          ordList []       ≡ true
  ordList-∷  : ∀ i is → ordList (i ∷ is) ≡ ≤-ItemList i is && ordList is
{-# ATP axiom ordList-[] #-}
{-# ATP axiom ordList-∷ #-}

OrdList : D → Set
OrdList is = ordList is ≡ true
{-# ATP definition OrdList #-}

postulate
  ordTree         : D → D
  ordTree-nilTree :       ordTree nilTree ≡ true
  ordTree-tip     : ∀ i → ordTree (tip i) ≡ true
  ordTree-node    : ∀ t₁ i t₂ →
                      ordTree (node t₁ i t₂) ≡
                      ordTree t₁ && ordTree t₂ && ≤-TreeItem t₁ i && ≤-ItemTree i t₂
{-# ATP axiom ordTree-nilTree #-}
{-# ATP axiom ordTree-tip #-}
{-# ATP axiom ordTree-node #-}

OrdTree : D → Set
OrdTree t = ordTree t ≡ true
{-# ATP definition OrdTree #-}

------------------------------------------------------------------------------
-- The program

-- The function toTree adds an item to a tree.

-- The items have an ordering ≤ defined over them. The item held at a
-- node of the tree is chosen so that the left subtree has items not
-- greater than it and the right subtree has items not less than it.

postulate
  toTree          : D
  toTree-nilTree  : ∀ item →   toTree · item · nilTree ≡ tip item
  toTree-tip      : ∀ item i → toTree · item · (tip i) ≡
                    if (i ≤ item)
                      then (node (tip i) item (tip item))
                      else (node (tip item) i (tip i))
  toTree-node     : ∀ item t₁ i t₂ →
                    toTree · item · (node t₁ i t₂) ≡
                       if (i ≤ item)
                         then (node t₁ i (toTree · item · t₂))
                         else (node (toTree · item · t₁) i t₂)
{-# ATP axiom toTree-nilTree #-}
{-# ATP axiom toTree-tip #-}
{-# ATP axiom toTree-node #-}

-- The function makeTree converts a list to a tree.
makeTree : D → D
makeTree is = lit toTree is nilTree
{-# ATP definition makeTree #-}

-- The function flatten converts a tree to a list.
postulate
  flatten         : D → D
  flatten-nilTree :       flatten nilTree ≡ []
  flatten-tip     : ∀ i → flatten (tip i) ≡ i ∷ []
  flatten-node    : ∀ t₁ i t₂ →
                    flatten (node t₁ i t₂)  ≡ flatten t₁ ++ flatten t₂
{-# ATP axiom flatten-nilTree #-}
{-# ATP axiom flatten-tip #-}
{-# ATP axiom flatten-node #-}

-- The function which sorts the list
sort : D → D
sort is = flatten (makeTree is)
{-# ATP definition sort #-}

------------------------------------------------------------------------------
-- Sort a list
------------------------------------------------------------------------------

-- This module define the program which sorts a list by converting it
-- into an ordered tree and then back to a list (Burstall, 1969, pp. 45-46).

-- R. M. Burstall. Proving properties of programs by structural
-- induction. The Computer Journal, 12(1):41–48, 1969.

module LTC.Program.SortList.SortList where

open import LTC.Base

open import LTC.Data.Bool using ( _&&_ )
open import LTC.Data.Nat.Inequalities using ( _≤_ )
open import LTC.Data.Nat.Type
  using ( N  -- The LTC natural numbers type.
        )
open import LTC.Data.List using ( _++_ )

------------------------------------------------------------------------------
-- Tree terms
postulate
  nilTree  : D
  tip      : D → D
  node     : D → D → D → D

-- The LTC tree type.
data Tree : D → Set where
  nilT  : Tree nilTree
  tipT  : ∀ {i} → N i → Tree (tip i)
  nodeT : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ → Tree (node t₁ i t₂)
{-# ATP hint nilT #-}
{-# ATP hint tipT #-}
{-# ATP hint nodeT #-}

------------------------------------------------------------------------------
-- Inequalites on lists and trees

-- Note from Burstall (p. 46): "The relation ≤ between lists is only an
-- ordering if nil is excluded, similarly for trees. This is untidy but
-- will not cause trouble."

postulate
  ≤-ItemList    : D → D → D
  ≤-ItemList-[] : ∀ item → ≤-ItemList item [] ≡ true
  ≤-ItemList-∷  : ∀ item i is →
                  ≤-ItemList item (i ∷ is) ≡ item ≤ i && ≤-ItemList item is
{-# ATP axiom ≤-ItemList-[] #-}
{-# ATP axiom ≤-ItemList-∷ #-}

LE-ItemList : D → D → Set
LE-ItemList item is = ≤-ItemList item is ≡ true
{-# ATP definition LE-ItemList #-}

postulate
  ≤-Lists    : D → D → D
  ≤-Lists-[] : ∀ is → ≤-Lists [] is ≡ true
  ≤-Lists-∷  : ∀ i is js →
               ≤-Lists (i ∷ is) js ≡ ≤-ItemList i js && ≤-Lists is js
{-# ATP axiom ≤-Lists-[] #-}
{-# ATP axiom ≤-Lists-∷ #-}

LE-Lists : D → D → Set
LE-Lists is js = ≤-Lists is js ≡ true
{-# ATP definition LE-Lists #-}

postulate
  ≤-ItemTree          : D → D → D
  ≤-ItemTree-nilTree  : ∀ item →   ≤-ItemTree item nilTree ≡ true
  ≤-ItemTree-tip      : ∀ item i → ≤-ItemTree item (tip i) ≡ item ≤ i
  ≤-ItemTree-node     : ∀ item t₁ i t₂ →
                          ≤-ItemTree item (node t₁ i t₂) ≡
                          ≤-ItemTree item t₁ && ≤-ItemTree item t₂
{-# ATP axiom ≤-ItemTree-nilTree #-}
{-# ATP axiom ≤-ItemTree-tip #-}
{-# ATP axiom ≤-ItemTree-node #-}

LE-ItemTree : D → D → Set
LE-ItemTree item t = ≤-ItemTree item t ≡ true
{-# ATP definition LE-ItemTree #-}

-- This function is not defined in the paper.
postulate
  ≤-TreeItem         : D → D → D
  ≤-TreeItem-nilTree : ∀ item →   ≤-TreeItem nilTree item ≡ true
  ≤-TreeItem-tip     : ∀ i item → ≤-TreeItem (tip i) item ≡ i ≤ item
  ≤-TreeItem-node    : ∀ t₁ i t₂ item →
                         ≤-TreeItem (node t₁ i t₂) item ≡
                         ≤-TreeItem t₁ item && ≤-TreeItem t₂ item
{-# ATP axiom ≤-TreeItem-nilTree #-}
{-# ATP axiom ≤-TreeItem-tip #-}
{-# ATP axiom ≤-TreeItem-node #-}

LE-TreeItem : D → D → Set
LE-TreeItem t item = ≤-TreeItem t item ≡ true
{-# ATP definition LE-TreeItem #-}

------------------------------------------------------------------------------
-- Auxiliary functions

postulate
  -- The foldr function with the last two args flipped.
  lit    : D → D → D → D
  lit-[] : ∀ (f : D) n →      lit f []       n ≡ n
  lit-∷  : ∀ (f : D) d ds n → lit f (d ∷ ds) n ≡ f · d · (lit f ds n)
{-# ATP axiom lit-[] #-}
{-# ATP axiom lit-∷ #-}

------------------------------------------------------------------------------
-- Ordering functions and predicates on lists and trees

postulate
  ordList    : D → D
  ordList-[] :          ordList []       ≡ true
  ordList-∷  : ∀ i is → ordList (i ∷ is) ≡ ≤-ItemList i is && ordList is
{-# ATP axiom ordList-[] #-}
{-# ATP axiom ordList-∷ #-}

OrdList : D → Set
OrdList is = ordList is ≡ true
{-# ATP definition OrdList #-}

postulate
  ordTree         : D → D
  ordTree-nilTree :       ordTree nilTree ≡ true
  ordTree-tip     : ∀ i → ordTree (tip i) ≡ true
  ordTree-node    : ∀ t₁ i t₂ →
                      ordTree (node t₁ i t₂) ≡
                      ordTree t₁ && ordTree t₂ && ≤-TreeItem t₁ i && ≤-ItemTree i t₂
{-# ATP axiom ordTree-nilTree #-}
{-# ATP axiom ordTree-tip #-}
{-# ATP axiom ordTree-node #-}

OrdTree : D → Set
OrdTree t = ordTree t ≡ true
{-# ATP definition OrdTree #-}

------------------------------------------------------------------------------
-- The program

-- The function toTree adds an item to a tree.

-- The items have an ordering ≤ defined over them. The item held at a
-- node of the tree is chosen so that the left subtree has items not
-- greater than it and the right subtree has items not less than it.

postulate
  toTree          : D
  toTree-nilTree  : ∀ item →   toTree · item · nilTree ≡ tip item
  toTree-tip      : ∀ item i → toTree · item · (tip i) ≡
                    if (i ≤ item)
                      then (node (tip i) item (tip item))
                      else (node (tip item) i (tip i))
  toTree-node     : ∀ item t₁ i t₂ →
                    toTree · item · (node t₁ i t₂) ≡
                       if (i ≤ item)
                         then (node t₁ i (toTree · item · t₂))
                         else (node (toTree · item · t₁) i t₂)
{-# ATP axiom toTree-nilTree #-}
{-# ATP axiom toTree-tip #-}
{-# ATP axiom toTree-node #-}

-- The function makeTree converts a list to a tree.
makeTree : D → D
makeTree is = lit toTree is nilTree
{-# ATP definition makeTree #-}

-- The function flatten converts a tree to a list.
postulate
  flatten         : D → D
  flatten-nilTree :       flatten nilTree ≡ []
  flatten-tip     : ∀ i → flatten (tip i) ≡ i ∷ []
  flatten-node    : ∀ t₁ i t₂ →
                    flatten (node t₁ i t₂)  ≡ flatten t₁ ++ flatten t₂
{-# ATP axiom flatten-nilTree #-}
{-# ATP axiom flatten-tip #-}
{-# ATP axiom flatten-node #-}

-- The function which sorts the list
sort : D → D
sort is = flatten (makeTree is)
{-# ATP definition sort #-}