0 | module Misc
  1 |
  2 | import Data.Nat
  3 | import Data.Vect
  4 | import Data.Vect.Elem
  5 | import System.Random
  6 | import Data.Fin
  7 | import Data.List1
  8 | import Data.Fin.Arith
  9 | import Data.List.Quantifiers
 10 | import Data.Vect.Quantifiers
 11 | import Decidable.Equality
 12 | import Decidable.Equality.Core
 13 | import Data.List
 14 |
 15 | %hide Builtin.infixr.(#)
 16 | %hide Data.Vect.Quantifiers.All.index
 17 |
 18 | namespace IsNo
 19 |   ||| IsNo is a type Idris can automatically synthesise, in contrast to
 20 |   ||| in contrast to `Not (x = y)`
 21 |   public export
 22 |   data IsNo : Dec a -> Type where
 23 |     ItIsNo : {prop : Type} -> {contra : Not prop} -> IsNo (No {prop=prop} contra)
 24 |
 25 |   ||| Can this be simplified?
 26 |   public export 
 27 |   isNoSym : DecEq a => {x, y : a} -> IsNo (decEq x y) -> IsNo (decEq y x)
 28 |   isNoSym z with (decEq x y) | (decEq y x)
 29 |     _ | (No contra1) | (Yes prf) = absurd (contra1 (sym prf))
 30 |     _ | _           | (No contra) = ItIsNo 
 31 |   
 32 |   public export
 33 |   [uniqueUninhabited] {0 a : Type} -> {x : a} -> (de : DecEq a) =>
 34 |   Uninhabited (IsNo (Equality.decEq x x)) where
 35 |     uninhabited y with (decEq x x)
 36 |       _ | (Yes _) with (y)
 37 |         _ | ItIsNo impossible
 38 |       _ | (No contra) = contra Refl
 39 |   
 40 |   
 41 |   ||| Proof of inequality yields IsNo
 42 |   public export
 43 |   proofIneqIsNo : {x, y : a} -> DecEq a =>
 44 |     Not (x = y) -> (IsNo (Equality.decEq x y))
 45 |   proofIneqIsNo f with (decEq x y)
 46 |     _ | (Yes prf) = absurd (f prf)
 47 |     _ | (No contra) = ItIsNo
 48 |
 49 |
 50 | namespace Applicative
 51 |   ||| Definition of liftA2 in terms of (<*>)
 52 |   public export
 53 |   liftA2 : Applicative f => f a -> f b -> f (a, b)
 54 |   liftA2 fa fb = ((,) <$> fa) <*> fb
 55 |   
 56 |   ||| Tensorial strength
 57 |   public export
 58 |   strength : Applicative f => a -> f b -> f (a, b)
 59 |   strength a fb = liftA2 (pure a) fb
 60 |   
 61 |   ||| Pointwise Num structure for Applicative functors
 62 |   public export
 63 |   [applicativeNum] Num a => Applicative f => Num (f a) where
 64 |     xs + ys = uncurry (+) <$> liftA2 xs ys
 65 |     xs * ys = uncurry (*) <$> liftA2 xs ys
 66 |     fromInteger = pure . fromInteger
 67 |
 68 |
 69 |
 70 | namespace VectFoldable
 71 |   ||| Implementation of Foldable for Vect that is denotationally equivalent to
 72 |   ||| one in Data.Vect, but which does not use `foldrImpl` and therefore
 73 |   ||| reduces in the typechecker
 74 |   public export
 75 |   [straightforward] Foldable (Vect n) where
 76 |     foldr f z [] = z
 77 |     foldr f z (x :: xs) = f x (foldr f z xs)
 78 |
 79 |   ||| toList with a different foldable implementation
 80 |   public export
 81 |   toList' : Vect n a -> List a
 82 |   toList' = foldr @{straightforward} (::) []
 83 |
 84 | ||| Drop the first i elements of a vector
 85 | ||| Analogous to Data.Vect.drop, except the index is Fin n instead of Nat
 86 | public export
 87 | drop : (i : Fin (S n)) -> Vect n a -> Vect (minus n (finToNat i)) a
 88 | drop FZ xs = rewrite minusZeroRight n in xs
 89 | drop (FS i) (x :: xs) = drop i xs
 90 |
 91 | namespace DropElem
 92 |   ||| Drop all the elements up and until the element `x` from a vector
 93 |   public export
 94 |   drop : DecEq a =>
 95 |     (xs : Vect n a) ->
 96 |     (elem : Elem x xs) ->
 97 |     Vect (n `minus` (finToNat (FS (elemToFin elem)))) a
 98 |   drop {n=S k} (_ :: xs) Here = rewrite minusZeroRight k in xs
 99 |   drop (_ :: xs) (There later) = drop xs later
100 |
101 |
102 | public export
103 | data NotElem : DecEq a => (x : a) -> (xs : Vect n a) -> Type where
104 |   NotInEmptyVect : DecEq a => {0 x : a} -> NotElem x []
105 |   NotInNonEmptyVect : DecEq a => {0 x, y : a} ->
106 |     (xs : Vect n a) ->
107 |     IsNo (decEq x y) ->
108 |     (ne : NotElem x xs) =>
109 |     NotElem x (y :: xs)
110 |
111 | public export
112 | notEqualNotElem : DecEq a =>
113 |   {0 x, y : a} ->
114 |   (neq : IsNo (decEq x y)) ->
115 |   NotElem x [y]
116 | notEqualNotElem neq = NotInNonEmptyVect [] neq
117 |
118 |
119 | ||| If an element `i` is not in the singleton list `[j]`, then `j` is not in
120 | ||| the singleton list `[i]`
121 | public export
122 | notElemSym : DecEq a => {i, j : a} -> NotElem i [j] -> NotElem j [i]
123 | notElemSym (NotInNonEmptyVect [] isNo) = notEqualNotElem (isNoSym isNo)
124 |
125 | ||| If an element `i` is in the singleton list `[j]`, then `j` is in the 
126 | ||| singleton list `[i]`
127 | public export
128 | elemSym : DecEq a => {i, j : a} -> Elem i [j] -> Elem j [i]
129 | elemSym Here = Here
130 |
131 | ||| This already exists in Data.Vect.Elem, but it is not marked with %hint
132 | emptyIsUninhabited : NotElem "i" []
133 | emptyIsUninhabited = NotInEmptyVect
134 |
135 | fe' : Not ("i" = "j")
136 | fe' = ?fe'_rhs
137 |
138 |
139 | fe : IsNo (decEq "i" "j")
140 | fe = ItIsNo
141 |
142 | ne : NotElem "i" ["j"]
143 | ne = NotInNonEmptyVect [] ItIsNo
144 |
145 |
146 | ||| Pointwise Num structure for Applicative functors
147 | public export
148 | [applicativeNum] Num a => Applicative f => Num (f a) where
149 |   xs + ys = uncurry (+) <$> liftA2 xs ys
150 |   xs * ys = uncurry (*) <$> liftA2 xs ys
151 |   fromInteger = pure . fromInteger
152 |
153 | ||| Duplicate of utilities for Data.Vect in their Naperian form
154 | namespace VectNaperianUtils
155 |   ||| Analogue of `(::)`
156 |   public export
157 |   cons : x -> (Fin l -> x) -> (Fin (S l) -> x)
158 |   cons x _ FZ = x
159 |   cons _ f (FS k') = f k'
160 |
161 |   -- dcons : x -> ((i : Fin k) -> i' i) -> ((i : Fin (S k)) -> i' (cons x i'))
162 |   
163 |   public export
164 |   head : (Fin (S l) -> x) -> x
165 |   head f = f FZ
166 |   
167 |   public export
168 |   tail : (Fin (S l) -> x) -> (Fin l -> x)
169 |   tail f = f . FS
170 |   
171 |   ||| All but the last element
172 |   public export
173 |   init : (Fin (S n) -> a) -> Fin n -> a
174 |   init f x = f (weaken x)
175 |   
176 |   ||| Analogus to `Data.Vect.take`
177 |   public export 
178 |   takeFin : (s : Fin (S n)) -> Vect n a -> Vect (finToNat s) a
179 |   takeFin FZ _ = []
180 |   takeFin (FS s) (x :: xs) = x :: takeFin s xs
181 |
182 | namespace Vect
183 |   public export
184 |   sum : Num a => Vect n a -> a
185 |   sum xs = foldr (+) (fromInteger 0) xs
186 |   
187 |   -- Because of the way foldr for Vect is implemented in Idris 
188 |   -- we have to use this approach below, otherwise allSuccThenProdSucc breaks
189 |   public export 
190 |   prod : Num a => Vect n a -> a
191 |   prod xs = foldr @{straightforward} (*) (fromInteger 1) xs
192 |   -- prod [] = fromInteger 1
193 |   -- prod (x :: xs) = x * prod xs
194 |
195 |   public export
196 |   argmax : Ord a => IsSucc n => Vect n a -> Fin n 
197 |   argmax [x] = FZ
198 |   argmax (x :: x' :: xs) = if x > index maxRest (x' :: xs) then FZ else FS maxRest
199 |     where maxRest = argmax (x' :: xs)
200 |   
201 |   public export
202 |   argmin : Ord a => IsSucc n => Vect n a -> Fin n
203 |   argmin = argmax @{Reverse} 
204 |   
205 |   ||| Dual to concat from Data.Vect
206 |   public export
207 |   unConcat : {n, m : Nat} -> Vect (n * m) a -> Vect n (Vect m a)
208 |   unConcat {n = 0} _ = []
209 |   unConcat {n = (S k)} xs = let (f, s) = splitAt m xs
210 |                             in f :: unConcat s
211 |
212 |
213 |
214 | namespace List
215 |   public export
216 |   sum : Num a => List a -> a
217 |   sum = foldr (+) (fromInteger 0) 
218 |
219 |   public export
220 |   prod : Num a => List a -> a
221 |   prod = foldr (*) (fromInteger 1)
222 |
223 |   public export
224 |   listZip : List a -> List b -> List (a, b)
225 |   listZip (x :: xs) (y :: ys) = (x, y) :: listZip xs ys
226 |   listZip _ _ = []
227 |   
228 |   public export
229 |   maxInList : Ord a => List a -> Maybe a
230 |   maxInList [] = Nothing
231 |   maxInList [x] = Just x
232 |   maxInList (x :: xs) = do
233 |     mx <- maxInList xs
234 |     pure (max x mx)
235 |
236 |
237 | namespace FinArithmetic
238 |   ||| Like weakenN from Data.Fin, but where n is on the other side of +
239 |   public export
240 |   weakenN' : (0 n : Nat) -> Fin m -> Fin (n + m)
241 |   weakenN' n x = rewrite plusCommutative n m in weakenN n x
242 |
243 |   ||| Like weakenN, but with mutliplication
244 |   ||| Like shiftMul, but without changing the value of the index
245 |   public export
246 |   weakenMultN : {n : Nat} ->
247 |     (m : Nat) -> {auto prf : IsSucc m} ->
248 |     (i : Fin n) -> Fin (m * n)
249 |   weakenMultN (S 0) {prf = ItIsSucc} i = rewrite multOneLeftNeutral n in i
250 |   weakenMultN (S (S k)) {prf = ItIsSucc} i = weakenN' n (weakenMultN (S k) i)
251 |
252 |   multRightUnit : (m : Nat) -> m * 1 = m
253 |   multRightUnit 0 = Refl
254 |   multRightUnit (S k) = cong S (multRightUnit k)
255 |
256 |   multRightZeroCancel : (m : Nat) -> m * 0 = 0
257 |   multRightZeroCancel 0 = Refl
258 |   multRightZeroCancel (S k) = multRightZeroCancel k
259 |
260 |   ||| Variant of `shift` from Data.Fin, but with multiplication
261 |   ||| Given an index i : Fin n, it recasts it as one where steps are stride sized
262 |   ||| That is, returns stride * i : Fin (stride * n)
263 |   ||| Implemented by recursing on i, adding stride each time
264 |   public export
265 |   shiftMul : {n : Nat} ->
266 |     (stride : Nat) -> {auto prf : IsSucc stride} ->
267 |     (i : Fin n) -> Fin (n * stride)
268 |   shiftMul (S s) {prf = ItIsSucc} FZ = FZ
269 |   shiftMul stride (FS i) = shift stride (shiftMul stride i)
270 |
271 |   shiftMulTest : shiftMul {n=3} 5 1 = 5
272 |   shiftMulTest = Refl
273 |
274 |   ||| Analogous to strengthen from Data.Fin
275 |   ||| Attempts to strengthen the bound on Fin (m + n) to Fin m
276 |   ||| If it doesn't succeed, then returns the remainder in Fin n
277 |   public export
278 |   strengthenN : {m, n : Nat} -> Fin (m + n) -> Either (Fin m) (Fin n)
279 |   strengthenN {m = 0} x = Right x
280 |   strengthenN {m = (S k)} FZ = Left FZ
281 |   strengthenN {m = (S k)} (FS x) with (strengthenN x)
282 |     _ | (Left p) = Left $ FS p
283 |     _ | (Right q) = Right q
284 |   -- strengthenN {m = 0} x = Nothing
285 |   -- strengthenN {m = (S k)} FZ = Just FZ
286 |   -- strengthenN {m = (S k)} (FS x) with (strengthenN x)
287 |   --   _ | Nothing = Nothing
288 |   --   _ | (Just p) = Just $ FS p
289 |     --= let t = strengthenN x
290 |     --  in ?strengthenN_rhs_3
291 |
292 |   -- strengthenN {n = 0} x = Just x
293 |   -- strengthenN {m = 0} {n = (S k)} FZ = Nothing
294 |   -- strengthenN {m = (S j)} {n = (S k)} FZ = Just FZ
295 |   -- strengthenN {m} {n = (S k)} (FS x)
296 |   --   = let t = strengthenN x
297 |   --         v = Fin.FS
298 |   --     in ?what -- strengthenN x
299 |
300 |
301 |   --         restCount = indexCount is -- fpn = 13 : Fin (20)
302 |   -- iCTest1 : indexCount {shape = [3, 4, 5]} [1, 2, 3] = 33
303 |   -- iCTest1 = ?iCTest_rhs
304 |   
305 |   ||| Like finS, but without wrapping
306 |   ||| finS' last = last
307 |   public export
308 |   finS' : {n : Nat} -> Fin n -> Fin n
309 |   finS' {n = 1} x = x
310 |   finS' {n = (S (S k))} FZ = FS FZ
311 |   finS' {n = (S (S k))} (FS x) = FS $ finS' x
312 |   --finS' {n = S _} x = case strengthen x of
313 |   --    Nothing => x
314 |   --    Just y => FS y
315 |
316 |   
317 |   ||| Adds two Fin n, and bounds the result
318 |   ||| Meaning (93:Fin 5) + (4 : Fin 5) = 4
319 |   public export
320 |   addFinsBounded : {n : Nat} -> Fin n -> Fin n -> Fin n
321 |   addFinsBounded x FZ = x
322 |   addFinsBounded x (FS y) = addFinsBounded (finS' x) (weaken y)
323 |
324 |   finSTest : finS' {n = 5} 3 = 4
325 |   finSTest = Refl
326 |
327 |   finSTest2 : finS' {n = 5} 4 = 4
328 |   finSTest2 = Refl
329 |
330 |   ||| Divides a Fin by 2, rounding down
331 |   public export
332 |   half : (k : Fin n) -> Fin n
333 |   half FZ = FZ
334 |   half (FS FZ) = FZ
335 |   half (FS (FS x)) = weakenN' 2 x
336 |
337 |   ||| Computes the midway index between two bounds
338 |   public export
339 |   mid : (low : Fin n) -> (high : Fin n) ->
340 |     {auto prf : So (high >= low)} ->
341 |     Fin n
342 |   mid FZ high = half high
343 |   mid (FS x) (FS y) {prf} = FS (mid x y)
344 |
345 | ||| Given a non-empty sorted vector `xs`, finds the "right bin", i.e. the index 
346 | ||| of the smallest element between the bounds that `x` is not bigger than.
347 | ||| If `x` is bigger than the highest element, returns `Nothing`
348 | ||| `findBinBetween [2,7,10] 1 0 2 = Just 0`
349 | ||| `findBinBetween [2,7,10] 3 0 2 = Just 1`
350 | ||| `findBinBetween [2,7,10] 9 0 2 = Just 2`
351 | ||| `findBinBetween [2,7,10] 7 0 2 = Just 2`
352 | ||| `findBinBetween [1,2,3,4,5] 6 0 4 = Nothing`
353 | public export
354 | findBinBetween : Ord a => {n : Nat} -> (xs : Vect (S n) a) ->
355 |   (x : a) ->
356 |   (lowInd : Fin (S n)) -> (highInd : Fin (S n)) ->
357 |   {auto prf : So (highInd >= lowInd)} ->
358 |   Maybe (Fin (S n))
359 | findBinBetween xs x lowInd highInd = case x > index highInd xs of
360 |   True => Nothing -- rule out the case where x is bigger
361 |   False => case x <= index lowInd xs of
362 |     True => Just lowInd
363 |     False => let midInd = mid lowInd highInd
364 |              in case compare x (index midInd xs) of
365 |                LT => findBinBetween xs x lowInd midInd {prf = believe_me ()}
366 |                EQ => Just midInd
367 |                GT => findBinBetween xs x (finS' midInd) highInd {prf = believe_me ()}
368 |
369 | ||| Todo can this eventually be generalised to non-cubical tensors?
370 | ||| Given a non-empty sorted vector `xs`, finds the "right bin", i.e. the index 
371 | ||| of the smallest element between the bounds that `x` is not bigger than.
372 | ||| If `x` is bigger than the highest element, returns `Nothing`
373 | ||| `findBin [2,7,10] 1 = Just 0`
374 | ||| `findBin [2,7,10] 3 = Just 1`
375 | ||| `findBin [2,4,6,8] 7 = Just 3`
376 | public export
377 | findBin : Ord a => {n : Nat} ->
378 |   (xs : Vect (S n) a) -> (x : a) -> Maybe (Fin (S n))
379 | findBin {n = 0} (x' :: []) x = case x' <= x of
380 |   True => Just FZ
381 |   False => Nothing
382 | findBin {n = (S k)} xs x = findBinBetween xs x 0 last
383 |
384 |
385 | -- t : Double -> Type
386 | -- t 4 = Double
387 | -- t _ = String
388 | -- 
389 | -- th : (x : Double ** t x)
390 | -- th = (4 ** 5)
391 | -- 
392 | -- thh : (x : Double) -> Show (t x)
393 | -- thh x = ?thh_rhs
394 |
395 | public export
396 | mkDepPairShow : Show a => (ss : (x : a) -> Show (b x)) => (DPair a b -> String)
397 | mkDepPairShow = \(x ** y=> "\{show x} ** \{show (y)}"
398 |
399 | public export
400 | Show a => ((x : a) -> Show (b x)) => Show (DPair a b) where
401 |    show = mkDepPairShow
402 |
403 | ||| Interface describing how a type can be displayed as a 2d grid of characters
404 | public export
405 | interface Display (a : Type) where
406 |   display : (x : a) -> (h : Nat ** w : Nat ** Vect h ((Vect w) Char))
407 |
408 | -- ||| Any type that implements Display can be shown as a string
409 | -- public export
410 | -- {a : Type} -> Display a => Show a where
411 | --   show x = let (h ** w ** xs) = display x
412 | --                ss = toList (intersperse "\n" (pack . toList <$> xs)) -- add intercalate here, and newline
413 | --            in fastUnlines ss
414 |
415 | -- public export
416 | -- Display Char where
417 | --   display x = (1 ** 1 ** [[x]])
418 |
419 | -- public export
420 | -- Num Unit where
421 | --   fromInteger _ = ()
422 | --   () * () = ()
423 | --   () + () = ()
424 |
425 | public export
426 | runIf: HasIO io => Bool -> io () -> io ()
427 | runIf True action = action
428 | runIf False action = pure ()
429 |
430 | public export
431 | pairIO : HasIO io => io a -> io b -> io (a, b)
432 | pairIO a b = do
433 |   a <- a
434 |   b <- b
435 |   pure (a, b)
436 |
437 |
438 | namespace RandomUtils
439 | -- Probably there's a faster way to do this
440 | -- public export
441 | -- {n : Nat} -> Random a => Random (Vect n a) where
442 | --   randomIO = sequence $ replicate n randomIO
443 | --   randomRIO (lo, hi) = sequence $ zipWith (\l, h => randomRIO (l, h)) lo hi
444 |
445 |   public export
446 |   Random Unit where
447 |     randomIO = pure ()
448 |     randomRIO _ = pure ()
449 |
450 |   public export
451 |   Random a => Random b => Random (a, b) where
452 |     randomIO = pairIO randomIO randomIO
453 |     randomRIO ((loA, loB), (hiA, hiB))
454 |       = pairIO (randomRIO (loA, hiA)) (randomRIO (loB, hiB))
455 |
456 |
457 |
458 | -- for reshaping a tensor
459 | rrrrr : {n, x, y : Nat}
460 |   -> Fin (S n)
461 |   -> {auto prf : n = x * y}
462 |   -> (Fin (S x), Fin (S y))
463 |   -- -> Data.Fin.Arith.(*) (Fin (S x)) (Fin (S y))
464 |
465 |
466 | ||| There is a similar function in Data.Fin.Arith, which has the smallest
467 | ||| possible bound. This one does not, but has a simpler type signature.
468 | public export
469 | multFin : {m, n : Nat} -> Fin m -> Fin n -> Fin (m * n)
470 | multFin {n = (S _)} FZ y = FZ
471 | multFin {n = (S _)} (FS x) y = y + weaken (multFin x y)
472 |
473 | ||| Splits xs at each occurence of delimeter (general version for lists)
474 | public export
475 | splitList : Eq a =>
476 |   (xs : List a) -> (delimeter : List a) -> (n : Nat ** Vect n (List a))
477 | splitList xs delimeter = 
478 |   if delimeter == []
479 |     then (1 ** [xs]-- Empty delimiter returns original list
480 |     else case isInfixOfList delimeter xs of
481 |       False => (1 ** [xs]-- Delimiter not found, return original list
482 |       True => 
483 |         let (before, after) = breakOnList delimeter xs
484 |         in case after of
485 |           [] => (1 ** [before]-- No more occurrences
486 |           _  => let (restCount ** restVect= splitList (drop (length delimeter) after) delimeter
487 |                 in (S restCount ** before :: restVect)
488 |   where
489 |     -- Check if list starts with delimiter
490 |     isPrefixOfList : List a -> List a -> Bool
491 |     isPrefixOfList [] _ = True
492 |     isPrefixOfList _ [] = False
493 |     isPrefixOfList (d :: ds) (x :: xs) = d == x && isPrefixOfList ds xs
494 |     
495 |     -- Check if delimiter occurs anywhere in the list
496 |     isInfixOfList : List a -> List a -> Bool
497 |     isInfixOfList del [] = del == []
498 |     isInfixOfList del xs@(_ :: xs') = 
499 |       isPrefixOfList del xs || isInfixOfList del xs'
500 |     
501 |     -- Break list at first occurrence of delimiter
502 |     breakOnList : List a -> List a -> (List a, List a)
503 |     breakOnList del xs = breakOnListAcc del xs []
504 |       where
505 |         breakOnListAcc : List a -> List a -> List a -> (List a, List a)
506 |         breakOnListAcc del remaining acc = 
507 |           case isPrefixOfList del remaining of
508 |             True => (reverse acc, remaining)
509 |             False => case remaining of
510 |               [] => (reverse acc, [])
511 |               (c :: cs) => breakOnListAcc del cs (c :: acc)
512 |
513 | ||| Splits xs at each occurence of delimeter (string version)
514 | public export
515 | splitString : (xs : String) -> (delimeter : String) -> (n : Nat ** Vect n String)
516 | splitString xs delimeter = 
517 |   let (n ** result= splitList (unpack xs) (unpack delimeter)
518 |   in (n ** pack <$> result)
519 |
520 | ||| Simple string replacement function
521 | public export
522 | replaceString : String -> String -> String -> String
523 | replaceString old new str = 
524 |   let chars = unpack str
525 |       oldChars = unpack old
526 |       newChars = unpack new
527 |   in pack (replaceInList oldChars newChars chars)
528 |   where
529 |     replaceInList : List Char -> List Char -> List Char -> List Char
530 |     replaceInList [] _ xs = xs
531 |     replaceInList old new [] = []
532 |     replaceInList old new xs@(x :: rest) =
533 |       if isPrefixOf old xs
534 |         then new ++ replaceInList old new (drop (length old) xs)
535 |         else x :: replaceInList old new rest
536 |
537 |
538 | public export
539 | constUnit : a -> Unit
540 | constUnit _ = ()
541 |
542 | public export
543 | const2Unit : a -> b -> Unit
544 | const2Unit _ _ = ()
545 |
546 | public export
547 | fromBool : Num a => Bool -> a
548 | fromBool False = fromInteger 0
549 | fromBool True = fromInteger 1
550 |
551 | public export
552 | applyWhen : Bool -> (a -> a) -> a -> a
553 | applyWhen False f a = a
554 | applyWhen True f a = f a
555 |
556 |
557 | namespace All
558 |   namespace Vect
559 |     public export
560 |     rewriteAllMap : {xs : Vect n a} ->
561 |       All p (f <$> xs) ->
562 |       All (p . f) xs
563 |     rewriteAllMap {xs = []} [] = []
564 |     rewriteAllMap {xs = (x :: xs)} (a :: as) = a :: rewriteAllMap as
565 |
566 |     public export
567 |     rewriteAllMap' : {xs : Vect n a} ->
568 |       All (p . f) xs ->
569 |       All p (f <$> xs)
570 |     rewriteAllMap' {xs = []} [] = []
571 |     rewriteAllMap' {xs = (x :: xs)} (a :: as) = a :: rewriteAllMap' as
572 |   
573 |   namespace List
574 |     public export
575 |     rewriteAllMap : {xs : List a} ->
576 |       All p (f <$> xs) ->
577 |       All (p . f) xs
578 |     rewriteAllMap {xs = []} [] = []
579 |     rewriteAllMap {xs = (x :: xs)} (a :: as) = a :: rewriteAllMap as
580 |
581 |   ||| Cnvert an all to a vector if it's made out of replicated things
582 |   public export
583 |   allToVect : Vect.Quantifiers.All.All p (replicate n a) -> Vect n (p a)
584 |   allToVect [] = []
585 |   allToVect (aa :: aaps) = aa :: allToVect aaps
586 |
587 |   public export
588 |   constantToVect : {xs : Vect n a} ->
589 |     Vect.Quantifiers.All.All (const b) xs -> Vect n b
590 |   constantToVect [] = []
591 |   constantToVect (bb :: bbs) = bb :: constantToVect bbs
592 |
593 |
594 | ||| Dependent parametric traverse
595 | public export
596 | dTraverse : Applicative f =>
597 |   ((p : pType) -> f (q p)) ->
598 |   (xs : Vect n pType) ->
599 |   f (All q xs)
600 | dTraverse f [] = pure []
601 | dTraverse f (p :: ps) = [| f p :: dTraverse f ps |]
602 |
603 |
604 | public export
605 | record Iso (a, b : Type) where
606 |   constructor MkIso
607 |   forward : a -> b
608 |   backward : b -> a
609 |   forwardBackward : (: a) -> backward (forward x) = x
610 |   backwardForward : (: b) -> forward (backward y) = y
611 |
612 | public export
613 | multSucc : {m, n : Nat} -> IsSucc m -> IsSucc n -> IsSucc (m * n)
614 | multSucc {m = S m'} {n = S n'} ItIsSucc ItIsSucc = ItIsSucc
615 |
616 | public export
617 | allSuccThenProdSucc : (xs : List Nat) -> {auto ps : All IsSucc xs} -> IsSucc (prod xs)
618 | allSuccThenProdSucc [] {ps = []} = ItIsSucc
619 | allSuccThenProdSucc (_ :: xs') {ps = p :: _} = multSucc p (allSuccThenProdSucc xs')
620 |
621 |
622 | public export
623 | updateAt : Eq a => (a -> b) -> (a, b) -> (a -> b)
624 | updateAt f (i, val) i' = if i == i' then val else f i'
625 |
626 |
627 | ||| Graph of a dependent function
628 | public export
629 | graph : {t : a -> Type} ->
630 |   (g : (x : a) -> t x) ->
631 |   a -> (x : a ** t x)
632 | graph g x = (x ** g x)
633 |
634 | ||| Version of `map` for dependent function
635 | ||| Note that here `x : a` is identity in some sense, it comes from `f a`
636 | public export
637 | dependentMap : Functor f => {t : a -> Type} ->
638 |   (g : (x : a) -> t x) ->
639 |   f a -> f (x : a ** t x)
640 | dependentMap g fa = map (graph g) fa
641 |
642 |
643 | -- ||| Duplicate of `index` from Data.Vect.Quantifiers.All, but with an
644 | -- ||| additional `public` export modifier
645 | public export
646 | index : (i : Fin k) -> Vect.Quantifiers.All.All p ts -> p (Vect.index i ts)
647 | index FZ (x :: xs) = x
648 | index (FS j) (x :: xs) = index j xs
649 |
650 |
651 | {-
652 |
653 | interface Comult (f : Type -> Type) a where
654 |   comult : f a -> f (f a)
655 |
656 | {shape : Vect n Nat} -> Num a => Comult (TensorA shape) a where
657 |   comult t = ?eir
658 |
659 | gg : TensorA [3] Double -> TensorA [3, 3] Double
660 | gg (TS xs) = TS $ map ?fn ?gg_rhs_0
661 |
662 | -- [1, 2, 3]
663 | -- can we even do outer product?
664 | -- we wouldn't need reduce, but something like multiply?
665 | outer : {f : Type -> Type} -> {a : Type}
666 |   -> (Num a, Applicative f, Algebra f a)
667 |   => f a -> f a -> f (f a)
668 | outer xs ys = let t = liftA2 xs ys
669 |               in ?outer_rhs 
670 |   
671 |  -}
672 |
673 | |||| filter' works without `with`?
674 | filter' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
675 | filter' p [] = (0 ** [])
676 | filter' p (x :: xs) = case filter' p xs of 
677 |   (_ ** xs'=> if p x then (_ ** x :: xs'else (_ ** xs')
678 |
679 | ||| filter'' implemented with `with`
680 | filter'' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
681 | filter'' p [] = (0 ** [])
682 | filter'' p (x :: xs) with (filter' p xs)
683 |   _ | (_ ** xs'= if p x then (_ ** x :: xs'else (_ ** xs')
684 |
685 | {-
686 | Prelude.absurd : Uninhabited t => t -> a
687 | believe_me : a -> b
688 |
689 | -}
690 |
691 |
692 |
693 |
694 |
695 | namespace Linearity
696 |   ll1 : {n : Nat} -> Vect n a -> Nat
697 |   ll1 {n} _ = n
698 |   
699 |   -- Should this be detected as `using` the variable `n`?
700 |   -- in pattern matching, we'd have to unify type of `xs` which has in itself `len`
701 |   -- and `n` which in this case is computed to be `S len`?
702 |   -- this step of `ll2` is decomposing `n` only one level down, but the entire recursion ends up using the entire `n`
703 |   ll2 : {0 n : Nat} -> Vect n a -> Nat
704 |   ll2 [] = 0
705 |   ll2 {n=S t} (x :: xs) = 1 + ll2 xs
706 |