104 lines
3.3 KiB
Idris
104 lines
3.3 KiB
Idris
module Quox.Thin.View
|
|
|
|
import public Quox.Thin.Base
|
|
import Quox.NatExtra
|
|
import Data.Singleton
|
|
import Data.SnocVect
|
|
|
|
%default total
|
|
|
|
public export
|
|
data View : OPE m n mask -> Type where
|
|
StopV : View Stop
|
|
DropV : (mask : Nat) -> (0 ope : OPE m n mask) -> View (Drop ope Refl)
|
|
KeepV : (mask : Nat) -> (0 ope : OPE m n mask) -> View (Keep ope Refl)
|
|
%name View.View v
|
|
|
|
private
|
|
0 stopEqs : OPE m 0 mask -> (m = 0, mask = 0)
|
|
stopEqs Stop = (Refl, Refl)
|
|
|
|
private
|
|
0 fromStop : (ope : OPE 0 0 0) -> ope = Stop
|
|
fromStop Stop = Refl
|
|
|
|
private
|
|
0 fromDrop : (ope : OPE m (S n) (k + k)) ->
|
|
(inner : OPE m n k ** ope === Drop inner Refl)
|
|
fromDrop (Drop ope eq) with %syntactic (doubleInj _ _ eq)
|
|
fromDrop (Drop ope Refl) | Refl = (ope ** Refl)
|
|
fromDrop (Keep ope eq) = void $ notEvenOdd _ _ eq
|
|
|
|
private
|
|
0 fromKeep : (ope : OPE (S m) (S n) (S (k + k))) ->
|
|
(inner : OPE m n k ** ope === Keep inner Refl)
|
|
fromKeep (Drop ope eq) = void $ notEvenOdd _ _ $ sym eq
|
|
fromKeep (Keep ope eq) with %syntactic (doubleInj _ _ $ inj S eq)
|
|
fromKeep (Keep ope Refl) | Refl = (ope ** Refl)
|
|
|
|
private
|
|
0 keepIsSucc : (ope : OPE m n (S (k + k))) -> IsSucc m
|
|
keepIsSucc (Drop ope eq) = void $ notEvenOdd _ _ $ sym eq
|
|
keepIsSucc (Keep ope _) = ItIsSucc
|
|
|
|
export
|
|
view : {0 m : Nat} -> {n, mask : Nat} -> (0 ope : OPE m n mask) -> View ope
|
|
view {n = 0} ope with %syntactic 0 (fst $ stopEqs ope) | 0 (snd $ stopEqs ope)
|
|
_ | Refl | Refl = rewrite fromStop ope in StopV
|
|
view {n = S n} ope with %syntactic (half mask)
|
|
_ | HalfOdd mask' with %syntactic 0 (keepIsSucc ope)
|
|
_ | ItIsSucc with %syntactic 0 (fromKeep ope)
|
|
_ | (ope' ** eq) = rewrite eq in KeepV mask' ope'
|
|
_ | HalfEven mask' with %syntactic 0 (fromDrop ope)
|
|
_ | (ope' ** eq) = rewrite eq in DropV mask' ope'
|
|
|
|
|
|
export
|
|
appOpe : {0 m : Nat} -> (n : Nat) -> {mask : Nat} ->
|
|
(0 ope : OPE m n mask) -> Singleton m
|
|
appOpe n ope with %syntactic (view ope)
|
|
appOpe 0 Stop | StopV = Val 0
|
|
appOpe (S n) (Drop ope' _) | DropV _ ope' = appOpe n ope'
|
|
appOpe (S n) (Keep ope' _) | KeepV _ ope' = [|S $ appOpe n ope'|]
|
|
|
|
export
|
|
maskToOpe : {n, mask : Nat} -> (0 ope : OPE m n mask) -> Singleton ope
|
|
maskToOpe ope with %syntactic (view ope)
|
|
maskToOpe Stop | StopV = [|Stop|]
|
|
maskToOpe (Drop ope Refl) | DropV k ope = [|drop $ maskToOpe ope|]
|
|
maskToOpe (Keep ope Refl) | KeepV k ope = [|keep $ maskToOpe ope|]
|
|
|
|
export
|
|
0 outerInnerZero : OPE m 0 mask -> m = 0
|
|
outerInnerZero Stop = Refl
|
|
|
|
export
|
|
0 outerMaskZero : OPE m 0 mask -> mask = 0
|
|
outerMaskZero Stop = Refl
|
|
|
|
export
|
|
0 viewStop : view Stop = StopV
|
|
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 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 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
|