wip

lib/Quox/Thin/Base.idr

@@ -53,7 +53,7 @@ id {m = 0}   = Element _ Stop
 id {m = S m} = Element _ $ Keep id.snd Refl
 
 public export %inline
-0 id' : OPE m m Base.id.fst
+0 id' : {m : Nat} -> OPE m m (fst (Base.id {m}))
 id' = id.snd
 
 ||| nothing selected

lib/Quox/Thin/Comp.idr

@@ -2,6 +2,7 @@ module Quox.Thin.Comp
 
 import public Quox.Thin.Base
 import public Quox.Thin.View
+import Quox.NatExtra
 import Data.Singleton
 
 %default total
@@ -52,8 +53,3 @@ export
 0 (.) : (ope1 : OPE n p mask1) -> (ope2 : OPE m n mask2) ->
         OPE m p (comp ope1 ope2).mask
 ope1 . ope2 = (comp ope1 ope2).ope
-
--- export
--- 0 compMask : (ope1 : OPE n p mask1) -> (ope2 : OPE m n mask2) ->
---              (ope3 : OPE m p mask3) -> Comp ope1 ope2 ope3 ->
---              mask3 = ?aaa

lib/Quox/Thin/Term.idr

@@ -5,6 +5,7 @@ import public Quox.Thin.Comp
 import public Quox.Thin.List
 import Quox.Thin.Eqv
 import public Quox.Thin.Cover
+import Quox.Thin.Append
 import Quox.Name
 import Quox.Loc
 import Data.DPair
@@ -15,6 +16,13 @@ import Decidable.Equality
 
 %default total
 
+private
+cmpMask : (m, n : Nat) -> Either Ordering (m = n)
+cmpMask 0     0     = Right Refl
+cmpMask 0     (S n) = Left  LT
+cmpMask (S m) 0     = Left  GT
+cmpMask (S m) (S n) = map (cong S) $ cmpMask m n
+
 public export
 record Thinned f n where
   constructor Th
@@ -26,9 +34,20 @@ record Thinned f n where
 
 export
 (forall n. Eq (f n)) => Eq (Thinned f n) where
-  s == t = case decEq s.scopeMask t.scopeMask of
-    Yes eq => s.term == (rewrite maskEqInner s.ope t.ope eq in t.term)
-    No  _  => False
+  s == t = case cmpMask s.scopeMask t.scopeMask of
+    Left  _  => False
+    Right eq => s.term == (rewrite maskEqInner s.ope t.ope eq in t.term)
+
+export
+(forall n. Ord (f n)) => Ord (Thinned f n) where
+  compare s t = case cmpMask s.scopeMask t.scopeMask of
+    Left  o  => o
+    Right eq => compare s.term (rewrite maskEqInner s.ope t.ope eq in t.term)
+
+export
+{n : Nat} -> (forall s. Show (f s)) => Show (Thinned f n) where
+  showPrec d (Th ope term) =
+    showCon d "Th" $ showArg (unVal $ maskToOpe ope) ++ showArg term
 
 export
 (forall n. Located (f n)) => Located (Thinned f n) where
@@ -47,6 +66,10 @@ namespace Thinned
   join : {n : Nat} -> Thinned (Thinned f) n -> Thinned f n
   join (Th ope1 (Th ope2 term)) = Th (ope1 . ope2) term
 
+  export
+  weak : {n : Nat} -> (by : Nat) -> Thinned f n -> Thinned f (by + n)
+  weak by (Th ope term) = Th (zero ++ ope).snd term
+
 
 public export
 record ScopedN (s : Nat) (f : Nat -> Type) (n : Nat) where
@@ -104,6 +127,14 @@ export
                  rewrite maskEqInner s.tope t.tope teq in t.term)
     _ => False
 
+export
+{d, n : Nat} -> (forall sd, sn. Show (f sd sn)) => Show (Thinned2 f d n) where
+  showPrec d (Th2 dope tope term) =
+    showCon d "Th2" $
+      showArg (unVal $ maskToOpe dope) ++
+      showArg (unVal $ maskToOpe tope) ++
+      showArg term
+
 export
 (forall d, n. Located (f d n)) => Located (Thinned2 f d n) where
   term.loc = term.term.loc
@@ -122,6 +153,12 @@ namespace Thinned2
   join (Th2 dope1 tope1 (Th2 dope2 tope2 term)) =
     Th2 (dope1 . dope2) (tope1 . tope2) term
 
+  export
+  weak : {d, n : Nat} -> (dby, nby : Nat) ->
+         Thinned2 f d n -> Thinned2 f (dby + d) (nby + n)
+  weak dby nby (Th2 dope tope term) =
+    Th2 (zero ++ dope).snd (zero ++ tope).snd term
+
 
 namespace TermList
   public export

lib/Quox/Thin/View.idr

@@ -4,6 +4,7 @@ import public Quox.Thin.Base
 import Quox.NatExtra
 import Data.Singleton
 import Data.SnocVect
+import Data.Fin
 
 %default total
 
@@ -52,6 +53,12 @@ view {n = S n} ope with %syntactic (half mask)
   _ | HalfEven mask' with %syntactic 0 (fromDrop ope)
     _ | (ope' ** eq) = rewrite eq in DropV mask' ope'
 
+export
+(.fin) : {n, mask : Nat} -> (0 ope : OPE 1 n mask) -> Fin n
+ope.fin with (view ope)
+  _.fin | DropV _ ope = FS ope.fin
+  _.fin | KeepV _ ope = FZ
+
 
 export
 appOpe : {0 m : Nat} -> (n : Nat) -> {mask : Nat} ->
@@ -83,21 +90,11 @@ viewStop = Refl
 export
 0 viewDrop : (ope : OPE m n mask) -> (eq : mask2 = mask + mask) ->
              view (Drop {mask} ope eq) = DropV mask ope
-viewDrop ope eq with (view (Drop ope eq))
+viewDrop ope eq with %syntactic (view (Drop ope eq))
   viewDrop ope Refl | DropV _ ope = Refl
 
 export
 0 viewKeep : (ope : OPE m n mask) -> (eq : mask2 = S (mask + mask)) ->
              view (Keep {mask} ope eq) = KeepV mask ope
-viewKeep ope eq with (view (Keep ope eq))
+viewKeep ope eq with %syntactic (view (Keep ope eq))
   viewKeep ope Refl | KeepV _ ope = Refl
-
-
-namespace SnocVect
-  export
-  select : {n, mask : Nat} -> (0 ope : OPE m n mask) ->
-           SnocVect n a -> SnocVect m a
-  select ope sx with (view ope)
-    select _ [<]       | StopV       = [<]
-    select _ (sx :< x) | DropV _ ope = select ope sx
-    select _ (sx :< x) | KeepV _ ope = select ope sx :< x