rename SubView to Sub (Sub to Sub') and port over props

lib/Quox/OPE/Length.idr

@@ -22,3 +22,8 @@ export
 0 ok : (s : Length xs) -> s.nat = length xs
 ok Z     = Refl
 ok (S s) = cong S $ ok s
+
+public export %hint
+toLength : (xs : Scope a) -> Length xs
+toLength [<]       = Z
+toLength (sx :< x) = S (toLength sx)

lib/Quox/OPE/Sub.idr

@@ -10,11 +10,11 @@ import Data.SnocList.Quantifiers
 %default total
 
 public export
-data Sub : Scope a -> Scope a -> Type where
+data Sub' : Scope a -> Scope a -> Type where
-  End  : [<] `Sub` [<]
+  End  : [<] `Sub'` [<]
-  Keep : xs `Sub` ys -> xs :< z `Sub` ys :< z
+  Keep : xs `Sub'` ys -> xs :< z `Sub'` ys :< z
-  Drop : xs `Sub` ys -> xs      `Sub` ys :< z
+  Drop : xs `Sub'` ys -> xs      `Sub'` ys :< z
-%name Sub p, q
+%name Sub' p, q
 
 export
 keepInjective : Keep p = Keep q -> p = q
@@ -28,196 +28,196 @@ dropInjective Refl = Refl
 -- these need to be `public export` so that
 -- `id`, `zero`, and maybe others can reduce
 public export %hint
-lengthLeft : xs `Sub` ys -> Length xs
+lengthLeft : xs `Sub'` ys -> Length xs
 lengthLeft End      = Z
 lengthLeft (Keep p) = S (lengthLeft p)
 lengthLeft (Drop p) = lengthLeft p
 
 public export %hint
-lengthRight : xs `Sub` ys -> Length ys
+lengthRight : xs `Sub'` ys -> Length ys
 lengthRight End      = Z
 lengthRight (Keep p) = S (lengthRight p)
 lengthRight (Drop p) = S (lengthRight p)
 
 
-export
+export %inline
-dropLast : (xs :< x) `Sub` ys -> xs `Sub` ys
+dropLast' : (xs :< x) `Sub'` ys -> xs `Sub'` ys
-dropLast (Keep p) = Drop p
+dropLast' (Keep p) = Drop p
-dropLast (Drop p) = Drop $ dropLast p
+dropLast' (Drop p) = Drop $ dropLast' p
 
 export
-Uninhabited (xs :< x `Sub` [<]) where uninhabited _ impossible
+Uninhabited (xs :< x `Sub'` [<]) where uninhabited _ impossible
 
 export
-Uninhabited (xs :< x `Sub` xs) where
+Uninhabited (xs :< x `Sub'` xs) where
   uninhabited (Keep p) = uninhabited p
-  uninhabited (Drop p) = uninhabited $ dropLast p
+  uninhabited (Drop p) = uninhabited $ dropLast' p
 
 
 export
-0 lteLen : xs `Sub` ys -> length xs `LTE` length ys
+0 lteLen : xs `Sub'` ys -> length xs `LTE` length ys
 lteLen End      = LTEZero
 lteLen (Keep p) = LTESucc $ lteLen p
 lteLen (Drop p) = lteSuccRight $ lteLen p
 
 export
-0 lteNilRight : xs `Sub` [<] -> xs = [<]
+0 lteNilRight : xs `Sub'` [<] -> xs = [<]
 lteNilRight End = Refl
 
 
 
 public export
-id : Length xs => xs `Sub` xs
+id' : Length xs => xs `Sub'` xs
-id @{Z}   = End
+id' @{Z}   = End
-id @{S s} = Keep id
+id' @{S s} = Keep id'
 
 public export
-zero : Length xs => [<] `Sub` xs
+zero' : Length xs => [<] `Sub'` xs
-zero @{Z}   = End
+zero' @{Z}   = End
-zero @{S s} = Drop zero
+zero' @{S s} = Drop zero'
 
 public export
-single : Length xs => x `Elem` xs -> [< x] `Sub` xs
+single' : Length xs => x `Elem` xs -> [< x] `Sub'` xs
-single @{S _} Here      = Keep zero
+single' @{S _} Here      = Keep zero'
-single @{S _} (There p) = Drop $ single p
+single' @{S _} (There p) = Drop $ single' p
 
 
 public export
-(.) : ys `Sub` zs -> xs `Sub` ys -> xs `Sub` zs
+trans' : ys `Sub'` zs -> xs `Sub'` ys -> xs `Sub'` zs
-End    . End    = End
+trans' End      End      = End
-Keep p . Keep q = Keep (p . q)
+trans' (Keep p) (Keep q) = Keep $ trans' p q
-Keep p . Drop q = Drop (p . q)
+trans' (Keep p) (Drop q) = Drop $ trans' p q
-Drop p . q      = Drop (p . q)
+trans' (Drop p) q        = Drop $ trans' p q
 
 public export
-(++) : xs1 `Sub` ys1 -> xs2 `Sub` ys2 -> (xs1 ++ xs2) `Sub` (ys1 ++ ys2)
+app' : xs1 `Sub'` ys1 -> xs2 `Sub'` ys2 -> (xs1 ++ xs2) `Sub'` (ys1 ++ ys2)
-p ++ End    = p
+app' p End      = p
-p ++ Keep q = Keep (p ++ q)
+app' p (Keep q) = Keep $ app' p q
-p ++ Drop q = Drop (p ++ q)
+app' p (Drop q) = Drop $ app' p q
-
-export
-0 appZeroRight : (p : xs `Sub` ys) -> p ++ zero @{len} {xs = [<]} = p
-appZeroRight {len = Z} p = Refl
 
 
 ||| if `p` holds for all elements of the main list,
 ||| it holds for all elements of the sublist
 public export
-subAll : xs `Sub` ys -> All p ys -> All p xs
+subAll' : xs `Sub'` ys -> All p ys -> All p xs
-subAll End      [<]       = [<]
+subAll' End      [<]       = [<]
-subAll (Keep q) (ps :< x) = subAll q ps :< x
+subAll' (Keep q) (ps :< x) = subAll' q ps :< x
-subAll (Drop q) (ps :< x) = subAll q ps
+subAll' (Drop q) (ps :< x) = subAll' q ps
 
 ||| if `p` holds for one element of the sublist,
 ||| it holds for one element of the main list
 public export
-subAny : xs `Sub` ys -> Any p xs -> Any p ys
+subAny' : xs `Sub'` ys -> Any p xs -> Any p ys
-subAny (Keep q) (Here  x) = Here x
+subAny' (Keep q) (Here  x) = Here x
-subAny (Keep q) (There x) = There (subAny q x)
+subAny' (Keep q) (There x) = There (subAny' q x)
-subAny (Drop q) x         = There (subAny q x)
+subAny' (Drop q) x         = There (subAny' q x)
 
 
 public export
-data SubMaskView : (lte : xs `Sub` ys) -> (mask : Nat) -> Type where
+data SubView : (lte : xs `Sub'` ys) -> (mask : Nat) -> Type where
   [search lte]
-  END  : SubMaskView End 0
+  END  : SubView End 0
-  KEEP : {n : Nat} -> {0 p : xs `Sub` ys} ->
+  KEEP : {n : Nat} -> {0 p : xs `Sub'` ys} ->
-         (0 v : SubMaskView p n) -> SubMaskView (Keep {z} p) (S (2 * n))
+         (0 v : SubView p n) -> SubView (Keep {z} p) (S (2 * n))
-  DROP : {n : Nat} -> {0 p : xs `Sub` ys} ->
+  DROP : {n : Nat} -> {0 p : xs `Sub'` ys} ->
-         (0 v : SubMaskView p n) -> SubMaskView (Drop {z} p)    (2 * n)
+         (0 v : SubView p n) -> SubView (Drop {z} p)    (2 * n)
-%name SubMaskView v
+%name SubView v
 
 public export
-record SubMask {a : Type} (xs, ys : Scope a) where
+record Sub {a : Type} (xs, ys : Scope a) where
   constructor SubM
   mask : Nat
-  0 lte : xs `Sub` ys
+  0 lte : xs `Sub'` ys
-  0 view0 : SubMaskView lte mask
+  0 view0 : SubView lte mask
-%name SubMask m
+%name Sub m
+
+
+export
+getMask : SubView lte mask -> Subset Nat (Equal mask)
 
 private
-0 ltemNilLeftZero' : SubMaskView {xs = [<]} lte mask -> mask = 0
+0 ltemNilLeftZero' : SubView {xs = [<]} lte mask -> mask = 0
 ltemNilLeftZero' END      = Refl
 ltemNilLeftZero' (DROP v) = cong (2 *) $ ltemNilLeftZero' v
 
 export
-ltemNilLeftZero : (0 _ : SubMaskView {xs = [<]} lte mask) -> mask = 0
+ltemNilLeftZero : (0 _ : SubView {xs = [<]} lte mask) -> mask = 0
 ltemNilLeftZero v = irrelevantEq $ ltemNilLeftZero' v
 
 
 private
-0 lteNilLeftDrop0 : (p : [<] `Sub` (xs :< x)) -> (q ** p = Drop q)
+0 lteNilLeftDrop0 : (p : [<] `Sub'` (xs :< x)) -> (q ** p = Drop q)
 lteNilLeftDrop0 (Drop q) = (q ** Refl)
 
 private
-lteNilLeftDrop : (0 p : [<] `Sub` (xs :< x)) -> Exists (\q => p = Drop q)
+lteNilLeftDrop : (0 p : [<] `Sub'` (xs :< x)) -> Exists (\q => p = Drop q)
 lteNilLeftDrop q =
   let 0 res = lteNilLeftDrop0 q in
   Evidence res.fst (irrelevantEq res.snd)
 
 private
-0 lteNil2End : (p : [<] `Sub` [<]) -> p = End
+0 lteNil2End : (p : [<] `Sub'` [<]) -> p = End
 lteNil2End End = Refl
 
 private
-0 ltemEnd' : SubMaskView p n -> p = End -> n = 0
+0 ltemEnd' : SubView p n -> p = End -> n = 0
 ltemEnd' END Refl = Refl
 
 private
-0 ltemEven' : {p : xs `Sub` (ys :< y)} ->
+0 ltemEven' : {p : xs `Sub'` (ys :< y)} ->
-              n = 2 * n' -> SubMaskView p n -> (q ** p = Drop q)
+              n = 2 * n' -> SubView p n -> (q ** p = Drop q)
 ltemEven' eq (KEEP q) = absurd $ lsbMutex' eq Refl
 ltemEven' eq (DROP q) = (_ ** Refl)
 
 private
-ltemEven : {0 p : xs `Sub` (ys :< y)} ->
+ltemEven : {0 p : xs `Sub'` (ys :< y)} ->
-           (0 _ : SubMaskView p (2 * n)) -> Exists (\q => p = Drop q)
+           (0 _ : SubView p (2 * n)) -> Exists (\q => p = Drop q)
 ltemEven q =
   let 0 res = ltemEven' Refl q in
   Evidence res.fst (irrelevantEq res.snd)
 
 private
-0 fromDROP' : {lte : xs `Sub` ys} -> n = 2 * n' ->
+0 fromDROP' : {lte : xs `Sub'` ys} -> n = 2 * n' ->
-              SubMaskView (Drop lte) n -> SubMaskView lte n'
+              SubView (Drop lte) n -> SubView lte n'
 fromDROP' eq (DROP {n} p) =
   let eq = doubleInj eq {m = n, n = n'} in
   rewrite sym eq in p
 
 private
-0 ltemOdd' : {p : (xs :< x) `Sub` (ys :< x)} -> {n' : Nat} ->
+0 ltemOdd' : {p : (xs :< x) `Sub'` (ys :< x)} -> {n' : Nat} ->
-                n = S (2 * n') -> SubMaskView p n -> (q ** p = Keep q)
+                n = S (2 * n') -> SubView p n -> (q ** p = Keep q)
 ltemOdd' eq (KEEP q) = (_ ** Refl)
 ltemOdd' eq (DROP q) = absurd $ lsbMutex' Refl eq
 ltemOdd' eq END      impossible
 
 private
-ltemOdd : (0 _ : SubMaskView p (S (2 * n))) -> Exists (\q => p = Keep q)
+ltemOdd : (0 _ : SubView p (S (2 * n))) -> Exists (\q => p = Keep q)
 ltemOdd q =
   let 0 res = ltemOdd' Refl q in
   Evidence res.fst (irrelevantEq res.snd)
 
 private
-0 ltemOddHead' : {p : (xs :< x) `Sub` (ys :< y)} -> {n' : Nat} ->
+0 ltemOddHead' : {p : (xs :< x) `Sub'` (ys :< y)} -> {n' : Nat} ->
-                    n = S (2 * n') -> SubMaskView p n -> x = y
+                 n = S (2 * n') -> SubView p n -> x = y
 ltemOddHead' eq (KEEP q) = Refl
 ltemOddHead' eq (DROP q) = absurd $ lsbMutex' Refl eq
 ltemOddHead' eq END      impossible
 
 private
-ltemOddHead : {0 p : (xs :< x) `Sub` (ys :< y)} ->
+ltemOddHead : {0 p : (xs :< x) `Sub'` (ys :< y)} ->
-              (0 _ : SubMaskView p (S (2 * n))) -> x = y
+              (0 _ : SubView p (S (2 * n))) -> x = y
 ltemOddHead q = irrelevantEq $ ltemOddHead' Refl q
 
 private
-0 fromKEEP' : {lte : xs `Sub` ys} -> n = S (2 * n') ->
+0 fromKEEP' : {lte : xs `Sub'` ys} -> n = S (2 * n') ->
-              SubMaskView (Keep lte) n -> SubMaskView lte n'
+              SubView (Keep lte) n -> SubView lte n'
 fromKEEP' eq (KEEP {n} p) =
   let eq = doubleInj (injective eq) {m = n, n = n'} in
   rewrite sym eq in p
 
 export
 view : Length xs => Length ys =>
-       (m : SubMask xs ys) -> SubMaskView m.lte m.mask
+       (m : Sub xs ys) -> SubView m.lte m.mask
 view @{Z} @{Z} (SubM {lte, view0, _}) =
   rewrite lteNil2End lte in
   rewrite ltemEnd' view0 (lteNil2End lte) in
@@ -245,20 +245,163 @@ view @{S sx} @{S sy} (SubM mask lte view0) with (viewLsb mask)
 
 export
 (.view) : Length xs => Length ys =>
-          (m : SubMask xs ys) -> SubMaskView m.lte m.mask
+          (m : Sub xs ys) -> SubView m.lte m.mask
 (.view) = view
 
 
 export
 ltemLen : Length xs => Length ys =>
-          xs `SubMask` ys -> length xs `LTE` length ys
+          xs `Sub` ys -> length xs `LTE` length ys
-ltemLen @{sx} @{sy} lte@(SubM m l _) with (lte.view)
+ltemLen @{sx} @{sy} sub@(SubM m l _) with (sub.view)
-  ltemLen @{sx} @{sy} lte@(SubM 0 End _) | END = LTEZero
+  ltemLen @{sx} @{sy} sub@(SubM 0 End _) | END = LTEZero
-  ltemLen @{S sx} @{S sy} lte@(SubM (S (2 * n)) (Keep p) _) | (KEEP q) =
+  ltemLen @{S sx} @{S sy} sub@(SubM (S (2 * n)) (Keep p) _) | (KEEP q) =
     LTESucc $ ltemLen $ SubM n p q
-  ltemLen @{sx} @{S sy} lte@(SubM (2 * n) (Drop p) _) | (DROP q) =
+  ltemLen @{sx} @{S sy} sub@(SubM (2 * n) (Drop p) _) | (DROP q) =
     lteSuccRight $ ltemLen $ SubM n p q
 
 export
-ltemNilRight : xs `SubMask` [<] -> xs = [<]
+ltemNilRight : xs `Sub` [<] -> xs = [<]
 ltemNilRight m = irrelevantEq $ lteNilRight m.lte
+
+
+public export %inline
+end : [<] `Sub` [<]
+end = SubM 0 End END
+
+public export %inline
+keep : xs `Sub` ys -> xs :< z `Sub` ys :< z
+keep (SubM mask lte view0) = SubM (S (2 * mask)) (Keep lte) (KEEP view0)
+
+public export %inline
+drop : xs `Sub` ys -> xs `Sub` ys :< z
+drop (SubM mask lte view0) = SubM (2 * mask) (Drop lte) (DROP view0)
+
+
+export %inline
+dropLast : Length xs => Length ys =>
+           (xs :< x) `Sub` ys -> xs `Sub` ys
+dropLast @{sx} @{sy} sub@(SubM mask lte _) with (sub.view)
+  dropLast sub@(SubM (S (2 * n)) (Keep p) _) | (KEEP v) =
+    SubM (2 * n) (Drop p) (DROP v)
+  dropLast @{_} @{S sy} sub@(SubM (2 * n) (Drop p) _) | DROP v =
+    drop $ dropLast $ SubM n p v
+
+
+export
+Uninhabited (xs :< x `Sub` [<]) where
+  uninhabited sub = void $ uninhabited sub.lte
+
+export
+Length xs => Uninhabited (xs :< x `Sub` xs) where
+  uninhabited @{sx} sub@(SubM mask lte view0) with (sub.view)
+    uninhabited @{S sx} sub@(SubM (S (2 * n)) (Keep p) _) | KEEP v =
+      uninhabited $ SubM n p v
+    uninhabited @{S sx} sub@(SubM (2 * n) (Drop p) _) | DROP v =
+      uninhabited $ dropLast $ SubM n p v
+
+
+export
+refl : Length xs => xs `Sub` xs
+refl @{Z}   = end
+refl @{S s} = keep refl
+
+export Reflexive (Scope a) Sub where reflexive = refl
+
+mutual
+  private
+  antisym_ : Length xs => Length ys =>
+             {0 p : xs `Sub'` ys} -> {0 q : ys `Sub'` xs} ->
+             SubView p m1 -> SubView q m2 -> xs = ys
+  antisym_ END       END = Refl
+  antisym_ (KEEP v1) (KEEP v2 {z}) @{S sx} @{S sy} =
+    cong (:< z) $ antisym (SubM _ _ v1) (SubM _ _ v2)
+  antisym_ (KEEP v1) (DROP v2) {p = Keep p} {q = Drop q} =
+    void $ succNotLTEpred $ lteLen q `transitive` lteLen p
+  antisym_ (DROP v1) (KEEP v2) {p = Drop p} {q = Keep q} =
+    void $ succNotLTEpred $ lteLen p `transitive` lteLen q
+  antisym_ (DROP v1) (DROP v2) {p = Drop p} {q = Drop q} =
+    void $ succNotLTEpred $ lteLen p `transitive` lteSuccLeft (lteLen q)
+
+  export
+  antisym : Length xs => Length ys => xs `Sub` ys -> ys `Sub` xs -> xs = ys
+  antisym p q = antisym_ p.view q.view
+
+export
+Antisymmetric (Scope a) Sub where
+  antisymmetric p q = antisym p q
+
+
+mutual
+  private
+  trans_ : Length xs => Length ys => Length zs =>
+           {0 p : xs `Sub'` ys} -> {0 q : ys `Sub'` zs} ->
+           SubView p m1 -> SubView q m2 -> xs `Sub` zs
+  trans_ END END = end
+  trans_ (KEEP v1) (KEEP v2) @{S sx} @{S sy} @{S sz} =
+    keep $ SubM _ _ v1 `trans` SubM _ _ v2
+  trans_ (DROP v1) (KEEP v2) @{sx} @{S sy} @{S sz} =
+    drop $ SubM _ _ v1 `trans` SubM _ _ v2
+  trans_ v1 (DROP v2) @{sx} @{sy} @{S sz} =
+    let Element m1' eq = getMask v1 in
+    drop $ SubM m1' _ (rewrite sym eq in v1) `trans` SubM _ _ v2
+
+  export
+  trans : Length xs => Length ys => Length zs =>
+          xs `Sub` ys -> ys `Sub` zs -> xs `Sub` zs
+  trans p q = trans_ p.view q.view
+
+  export
+  (.) : Length xs => Length ys => Length zs =>
+        xs `Sub` ys -> ys `Sub` zs -> xs `Sub` zs
+  (.) = trans
+
+export
+Transitive (Scope a) Sub where
+  transitive p q = trans p q
+
+
+export
+zero : Length xs => [<] `Sub` xs
+zero @{Z}   = end
+zero @{S s} = drop zero
+
+export
+single : Length xs => x `Elem` xs -> [< x] `Sub` xs
+single @{S sx} Here      = keep zero
+single @{S sx} (There p) = drop $ single p
+
+
+export
+(++) : Length xs2 => Length ys2 =>
+       xs1 `Sub` ys1 -> xs2 `Sub` ys2 -> (xs1 ++ xs2) `Sub` (ys1 ++ ys2)
+(++) sub1 sub2@(SubM {}) @{sx2} @{sy2} with (sub2.view)
+  (++) sub1 sub2@(SubM {}) | END = sub1
+  (++) sub1 sub2@(SubM {}) @{S sx2} @{S sy2} | KEEP v = keep $ sub1 ++ SubM _ _ v
+  (++) sub1 sub2@(SubM {}) @{sx2} @{S sy2} | DROP v = drop $ sub1 ++ SubM _ _ v
+
+
+||| if `p` holds for all elements of the main list,
+||| it holds for all elements of the sublist
+export
+subAll : Length xs => Length ys =>
+         xs `Sub` ys -> All prop ys -> All prop xs
+subAll sub@(SubM {}) ps @{sx} @{sy} with (sub.view)
+  subAll sub@(SubM {}) [<] | END = [<]
+  subAll sub@(SubM {}) (ps :< p) @{S sx} @{S sy} | KEEP v =
+    subAll (SubM _ _ v) ps :< p
+  subAll sub@(SubM {}) (ps :< p) @{sx} @{S sy} | DROP v =
+    subAll (SubM _ _ v) ps
+
+
+||| if `p` holds for one element of the sublist,
+||| it holds for one element of the main list
+export
+subAny : Length xs => Length ys =>
+         xs `Sub` ys -> Any prop xs -> Any prop ys
+subAny sub@(SubM {}) p @{sx} @{sy} with (sub.view)
+  subAny sub@(SubM {}) p | END impossible
+  subAny sub@(SubM {}) (Here p) | KEEP v = Here p
+  subAny sub@(SubM {}) (There p) @{S sx} @{S sy} | KEEP v =
+    There $ subAny (SubM _ _ v) p
+  subAny sub@(SubM {}) p @{sx} @{S sy} | DROP v =
+    There $ subAny (SubM _ _ v) p