module BSTskel where
{--- Example of Dependently-typed program verfication. Inspired by
Bove & Dyber, Dependent Types at Work.
---}
open import Data.Nat
open import Data.Bool hiding (_≟_)
open import Data.Unit hiding (_≤_;_≤?_;_≟_;total)
open import Data.Product
open import Data.Empty
open import Data.Sum
open import Relation.Nullary
open import Relation.Binary
-- Some Properties of ≤ for natural numbers
trans : Transitive _≤_
trans z≤n _ = z≤n
trans (s≤s m≤n) (s≤s n≤o) = s≤s (trans m≤n n≤o)
≤-refl : forall {n} -> n ≤ n
≤-refl {zero} = z≤n
≤-refl {suc m} = s≤s (≤-refl {m})
total : ∀ ( m n : ℕ) -> m ≤ n ⊎ n ≤ m
total zero _ = inj₁ z≤n
total _ zero = inj₂ z≤n
total (suc m) (suc n) with total m n
... | inj₁ m≤n = inj₁ (s≤s m≤n)
... | inj₂ n≤m = inj₂ (s≤s n≤m)
-- A binary search tree that enforces the BST invariant---all vals
-- on the left subtree are greater-eq than the current val, which
-- is greater-eq than all vals on the right.
mutual
data BSTree : Set where
leaf : BSTree
node : (a : ℕ) -> (l : BSTree) -> ( r : BSTree) ->
allT (λ x -> a ≤ x) l -> allT (λ x -> x ≤ a) r -> BSTree
allT : (ℕ -> Set) -> BSTree -> Set
allT p leaf = ⊤
allT p (node x l r p1 p2) = p x × (allT p l) × (allT p r)
f : { x : ℕ } -> Set
f = ⊤
g = f {2}
{-
-- all elts in tree >= a (actually just looking at right spine (min))
_>=T_ : BSTree -> ℕ -> Set
leaf >=T a = ⊤
(node x l r _ _) >=T a = (a ≤ x) × (r >=T a)
-- all elts in tree <= a (actually just looking at left spine (max))
_<=T_ : BSTree -> ℕ -> Set
leaf <=T a = ⊤
(node x l r _ _) <=T a = (x ≤ a) × (l <=T a)
-- Our two relations are transitive
trans-<=T : forall {m n} -> (r : BSTree) -> r <=T m -> m ≤ n -> r <=T n
trans-<=T leaf tt q = tt
trans-<=T (node n' l r p1 p2) (q11 , q12) q2 = trans q11 q2 , trans-<=T l q12 q2
trans->=T : forall {m n} -> (r : BSTree) -> r >=T m -> n ≤ m -> r >=T n
trans->=T = {!!}
-- determine whether an element is in the tree
lookup : BSTree -> ℕ -> Bool
lookup leaf n = false
lookup (node m l r p1 p2) n with m ≟ n
... | yes _ = true
... | no _ with total m n
... | inj₁ _ = lookup r n
... | inj₂ _ = lookup l n
-- insert a new value in the tree
mutual
insert : BSTree -> ℕ -> BSTree
insert leaf n = node n leaf leaf tt tt
insert (node m l r p1 p2) n with total m n
... | inj₁ q = node m (insert l n) r (ins-geqT l p1 q) p2
... | inj₂ q = node m l (insert r n) p1 {!!}
ins-geqT : { n x : ℕ } -> (t : BSTree) -> t >=T x -> x ≤ n -> insert t n >=T x
ins-geqT leaf q1 q2 = q2 , _
ins-geqT {n} (node m l r p1 p2) q1 q2 with total m n
... | inj₁ q = q1
... | inj₂ q = proj₁ q1 , ins-geqT r (proj₂ q1) q2
-- predicate on whether a tree is a node or leaf
isNode : BSTree -> Set
isNode (node _ _ _ _ _) = ⊤
isNode leaf = ⊥
-- find the minimum element of (non-empty) trees
min : (n : BSTree) -> { pf : isNode n } -> ℕ
min leaf { () }
min (node a l leaf _ _) = a
min (node a l (node a' l' r' p1' p2') _ _) = min (node a' l' r' p1' p2')
-- Given a tree that is not a leaf, delete its minimum
-- element and return the new tree
mutual
delete-min : (n : BSTree) -> isNode n -> BSTree
delete-min leaf ()
delete-min (node a l leaf _ _) _ = l
delete-min (node a l (node a' l' r' p1' p2') p1 p2) _ =
(node a l (delete-min (node a' l' r' p1' p2') tt) p1 (mono _ _ a p2))
mono : (t : BSTree) -> (pf : isNode t) -> ( a : ℕ) -> t <=T a -> delete-min t pf <=T a
mono leaf () a _
mono (node b l leaf p1 p2) _ a ( q1 , q2 ) = q2
mono (node b l (node a' l' r' p1' p2') p1 p2) _ a ( q1 , q2 ) = q1 , q2
-- HINT: Important lemma(s) for BST deletion
-- deleting the minimum from a tree produces a tree where every node
-- is greater-eq than that minimum
min-l : forall {n l r p1 p2} ->
delete-min (node n l r p1 p2) tt >=T min (node n l r p1 p2) tt
min-l = {!!}
delete-min-pres : (t : BSTree) -> (pf : isNode t) -> (m : ℕ) -> t <=T m -> delete-min t pf <=T m
delete-min-pres = {!!}
-- If a tree is geq m, then m is less than the minimum of the tree
min-geq : (t : BSTree) -> (p : isNode t) -> (m : ℕ) ->
t >=T m -> m ≤ min t p
min-geq = {!!}
--
min-leq : (t : BSTree) -> (p : isNode t) -> (m : ℕ) ->
t <=T m -> min t p ≤ m
min-leq = {!!}
-- BST deletion
mutual
delete : BSTree -> ℕ -> BSTree
delete leaf n = leaf
delete (node m l r p1 p2) n with n ≟ m | total n m
... | no _ | inj₁ _ = node m l (delete r n) p1 {! !}
... | no _ | inj₂ _ = node m (delete l n) r {!!} p2
... | yes q1 | _ with l | r
... | leaf | _ = r
... | _ | leaf = l
... | (node ln ll lr lp1 lp2) | (node rn rl rr rp1 rp2) =
(node (min (node ln ll lr lp1 lp2) tt)
(delete-min (node ln ll lr lp1 lp2) tt)
(node rn rl rr rp1 rp2)
(min-l {ln} {ll} {lr} {lp1} {lp2})
(trans-<=T (node rn rl rr rp1 rp2) p2 (min-geq (node ln ll lr lp1 lp2) _ m p1)))
delete-r : ( r : BSTree) -> (n : ℕ) -> (m : ℕ) -> r <=T m -> (delete r n <=T m)
delete-r leaf n m pf = tt
delete-r (node m l r p1 p2) n m' pf with n ≟ m | total n m
... | no _ | inj₁ _ = pf
... | no _ | inj₂ _ = proj₁ pf , delete-r l n m' (proj₂ pf)
... | yes q1 | _ with l | r
... | leaf | r' = ( trans-<=T r' p2 (proj₁ pf) )
... | (node ln ll lr lp1 lp2) | leaf = proj₂ pf
... | (node ln ll lr lp1 lp2) | (node rn rl rr rp1 rp2) =
min-leq (node ln ll lr lp1 lp2) _ m' (proj₂ pf) ,
mono (node ln ll lr lp1 lp2) tt m' (proj₂ pf)
-}