quox/lib/Quox/Thin/View.idr

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