text:
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}

module Game
  ( runGame
  ) where

import           Apecs
import           ApecsExts
import           Apecs.Experimental.Reactive
import           Data.Maybe
import           Data.List (union, (\\))
import qualified Data.Vector.Storable as V
import           Control.Concurrent
import           Control.Lens hiding (Level, set)
import           Control.Monad
import           Control.Monad.Random
import           Graphics.UI.GLFW   (Key, KeyState)
import qualified Graphics.UI.GLFW   as GLFW
import           Linear.V2             (V2 (..), _x, _y)
import           Linear.Metric (distance)
import qualified Math.Geometry.Grid           as Grid
import           Math.Geometry.Grid.Octagonal (RectOctGrid, rectOctGrid)
import qualified Math.Geometry.GridMap        as GridMap
import           Numeric.Vector
import           Safe                         (headMay)

import Configuration
import qualified Dungeon
import ViewModel

newtype Position = Position Vec2i deriving (Eq, Ord, Show)
instance Component Position where type Storage Position = Reactive (OrdMap Position) (Map Position)

-- | Get list of entities that have the given Position
{-# INLINE whatsAt #-}
-- stupid ordLookup drags in MonadIO
whatsAt :: (MonadIO m, Has w m Position) => Vec2i -> SystemT w m [Entity]
whatsAt = withReactive . ordLookup . Position

{-# INLINE cmapAt #-}
cmapAt :: forall w m cx cy. (MonadIO m, Has w m Position, Get w m cx, Set w m cy)
       => Vec2i -> (cx -> cy) -> SystemT w m ()
cmapAt pos f = whatsAt pos >>= flip cmapOver f

{-# INLINE cmapMAt #-}
cmapMAt :: forall w m cx cy. (MonadIO m, Has w m Position, Get w m cx, Set w m cy)
        => Vec2i -> (cx -> SystemT w m cy) -> SystemT w m ()
cmapMAt pos sys = whatsAt pos >>= flip cmapMOver sys

{-# INLINE cfoldAt #-}
cfoldAt :: forall w m c a. (MonadIO m, Has w m Position, Get w m c)
        => Vec2i -> (a -> c -> a) -> a -> SystemT w m a
cfoldAt pos f a0 = whatsAt pos >>= \es -> cfoldOver es f a0

{-# INLINE extractAt #-}
extractAt :: forall w m c a. (MonadIO m, Has w m Position, Get w m c)
          => Vec2i -> (c -> a) -> SystemT w m (Maybe a)
extractAt pos selector = whatsAt pos >>= flip extractOver selector

{-# INLINE extractAllAt #-}
extractAllAt :: forall w m c a. (MonadIO m, Has w m Position, Get w m c)
             => Vec2i -> (c -> a) -> SystemT w m [a]
extractAllAt pos selector = whatsAt pos >>= flip extractAllOver selector

{-# INLINE existsAt #-}
existsAt :: forall w m c. (MonadIO m, Has w m Position, Get w m c) => Vec2i -> Proxy c -> SystemT w m Bool
existsAt pos p = whatsAt pos >>= \es -> existsOver es p

data Wall = Wall deriving Show
instance Component Wall where type Storage Wall = Map Wall

data Player = Player deriving Show
instance Component Player where type Storage Player = Unique Player

data Enemy = Enemy deriving Show
instance Component Enemy where type Storage Enemy = Map Enemy

newtype Time = Time Double deriving (Show, Num)
instance Semigroup Time where (<>) = error "unexpected use of Semigroup Time <>"
instance Monoid Time where mempty = 0
instance Component Time where type Storage Time = Global Time

newtype Grid = Grid RectOctGrid
instance Component Grid where type Storage Grid = Global Grid
instance Monoid Grid where mempty = Grid $ rectOctGrid 0 0
instance Semigroup Grid where (<>) = error "unexpected use of Semigroup Grid <>"

newtype KeysDown = KeysDown [Key]
instance Component KeysDown where type Storage KeysDown = Global KeysDown
deriving instance Monoid KeysDown
deriving instance Semigroup KeysDown

newtype Direction = Direction (V2 Int)
instance Component Direction where type Storage Direction = Global Direction
instance Monoid Direction where mempty = Direction $ V2 0 1
instance Semigroup Direction where (<>) = error "unexpected use of Semigroup Direction <>"

-- what about ''Camera? see Apecs.Gloss

-- creates type World and function initWorld :: IO World
makeWorld "World" [''Position, ''Wall, ''Player, ''Enemy,
                   ''Time, ''Grid, ''KeysDown,
                   ''Direction]

type System' a = System World a

initialize :: System' ()
initialize = do
  let rows = 100
      columns = 100
  level <- liftIO $ Dungeon.execLevelGen columns rows (Dungeon.rndLvl 3 20 0.7)
  let walls = map fst $ filter (isNothing . snd) $ Dungeon.allCells level
  forM_ walls $ \pos ->
    newEntity (Wall, Position pos)
  let (spawnX, spawnY) = head $ GridMap.keys . GridMap.filter isJust $ level
  _ <- newEntity (Player, Position (vec2 spawnX spawnY))
  replicateM_ 100 $ do
    place <- liftIO $ evalRandIO $ Dungeon.findRandomCell level isJust
    void $ newEntity (Enemy, Position (fst place))
  set global $ Grid $ rectOctGrid rows columns

keyToMotion :: Key -> Maybe (V2 Int)
keyToMotion key =
  case key of
    GLFW.Key'Left  -> Just $ V2 (-1) 0
    GLFW.Key'Right -> Just $ V2 1 0
    GLFW.Key'Up    -> Just $ V2 0 (-1)
    GLFW.Key'Down  -> Just $ V2 0 1
    _              -> Nothing

handleEvent :: Event -> System' ()
handleEvent (KeyEvent key keyState)
  | keyState `elem` [GLFW.KeyState'Pressed, GLFW.KeyState'Repeating]
  = do
      KeysDown keysDown <- get global
      let keysDown' = keysDown `union` [key]
      set global $ KeysDown keysDown'
      Direction dir <- get global
      forM_ (keyToMotion key) $ \motion -> do
        let dir' = signum $ dir + motion
            dir''
              -- opposite motion => opposite dir
              | dir' == 0
              = motion
              -- stuck on diagonal => motion turns dir to horiz/vert
              | dir' == dir
              = motion
              | otherwise
              = dir'
        set global $ Direction dir''
  | keyState == GLFW.KeyState'Released
  = do
      KeysDown keysDown <- get global
      let keysDown' = keysDown \\ [key]
      set global $ KeysDown keysDown'
      Direction (V2 x y) <- get global
      when (null keysDown' && keysDown == [GLFW.Key'Space]) $ do
        step (Vec2 x y)
        worldStep
handleEvent Begin
  = return ()

allows :: RectOctGrid -> Vec2i -> Bool
allows grid (Vec2 x y) = grid `Grid.contains` (x, y)

gridAllows :: Vec2i -> System' Bool
gridAllows pos = do
  Grid grid <- get global
  return $ grid `allows` pos

step :: Vec2i -> System' ()
step motion = cmapM $ \(Player, Position pos) -> do
  let pos' = pos + motion
  there <- whatsAt pos'
  ok <- gridAllows pos'
  return $ if ok && null there
    then Right $ Position pos'
    else Left ()

worldStep :: System' ()
worldStep = cmapM $ \(Player, Position playerPos, Grid grid) -> do
  cmapM $ \(Enemy, Position enemyPos) -> do
    let deltaPos@(Vec2 dx dy) = playerPos - enemyPos
        dist :: Float = sqrt (realToFrac $ dx*dx + dy*dy)
    if dist < 5
      then do
        let pos' = enemyPos + signum deltaPos
        there <- whatsAt pos'
        return $ if grid `allows` pos' && null there
          then Right $ Position pos'
          else Left ()
      else return $ Left ()
  return ()

runGame :: Chan Event -> MVar ViewModel -> MVar ViewState -> IO ()
runGame eventChan vmVar vsVar = do
  w <- initWorld
  writeChan eventChan Begin
  runWith w $ do
    initialize
    forever $ do
      event <- liftIO $ readChan eventChan
      handleEvent event
      oldVm <- liftIO $ readMVar vmVar
      vs <- liftIO $ readMVar vsVar
      newVm <- viewModelUpdate oldVm vs
      void $ liftIO $ swapMVar vmVar newVm

viewModelUpdate :: ViewModel -> ViewState -> System' ViewModel
viewModelUpdate ViewModel{ camHeight } ViewState{ aspectRatio, camPos } = do
  mayPos <- extract $ \(Player, Position pos) -> pos
  let Vec2 x y = case mayPos of
        Just pl -> pl
        Nothing -> error "player entity doesn't exist"
      playerPos = fromIntegral <$> V2 x y
      camStep = makeCamStep playerPos
      cam@(V2 camX camY) = fromMaybe playerPos camPos
      camWidth = aspectRatio * camHeight
      margin = 1 + distance playerPos cam
      left = camX - 0.5 * camWidth - margin
      right = camX + 0.5 * camWidth + margin
      top = camY - 0.5 * camHeight - margin
      bottom = camY + 0.5 * camHeight + margin
      -- rounding away from zero
      bound x =
        let x' = ceiling (abs x)
        in if x < 0 then - x' else x'
      idxs = [Vec2 x y | y <- [bound top..bound bottom], x <- [bound left..bound right]]
  Grid grid <- get global
  walls <- (V.fromList <$>) . fmap catMaybes . forM idxs $ \idx -> do
    isWall <- existsAt idx $ Proxy @Wall
    return $ if isWall then Just idx else Nothing
  enemies <- extractAll $ \(Enemy, Position pos) -> pos
  Direction (V2 dx dy) <- get global
  return ViewModel
    { camStep
    , camHeight
    , playerPos = Vec2 x y
    , dirIndicator = Vec2 dx dy
    , walls
    , enemies
    }

makeCamStep :: V2 Float -> Float -> Maybe (V2 Float) -> V2 Float
makeCamStep playerPos _ Nothing = playerPos
makeCamStep playerPos deltaT (Just camPos) = camPos''
  where
    baseSpeed = 2.5 -- approach speed in cells per second at distance 1
    minSpeed = 1.5
    dist :: V2 Float = playerPos - camPos
    vel :: V2 Float = pure baseSpeed * dist -- inherits sign of dist
    vel' = fmap (max minSpeed . abs) vel * signum vel
    step = vel' * pure deltaT
    camAt' = camPos + step
    -- now prevent overshoot
    dist' = playerPos - camAt'
    snap _ax = if signum (dist'^._ax) == signum (dist^._ax) then camAt'^._ax else playerPos^._ax
    camPos'' = V2 (snap _x) (snap _y)

ext: hs

max_stars_repo_name: cjay/some-roguelike

max_issues_repo_name: cjay/some-roguelike

max_forks_repo_name: cjay/some-roguelike

lm_label:
1. YES
2. NO


text:
{-# language TypeFamilies          #-}
{-# language FlexibleInstances     #-}
{-# language FlexibleContexts      #-}
{-# language MultiParamTypeClasses #-}
{-# language UndecidableInstances  #-}
{-# language Rank2Types            #-}
{-# language ScopedTypeVariables   #-}
{-# language TypeOperators #-}

module Feldspar.Software.Frontend where

import Feldspar.Sugar
import Feldspar.Representation
import Feldspar.Frontend
import Feldspar.Array.Vector hiding (reverse, (++))
import Feldspar.Array.Buffered (ArraysSwap(..))
import Feldspar.Software.Primitive
import Feldspar.Software.Primitive.Backend ()
import Feldspar.Software.Expression
import Feldspar.Software.Representation
import Data.Struct

import Data.Bits (Bits, FiniteBits)
import Data.Complex
import Data.Constraint hiding (Sub)
import Data.Proxy
import Data.List (genericLength)
import Data.Word hiding (Word)

-- syntactic.
import Language.Syntactic (Syntactic(..))
import Language.Syntactic.Functional
import qualified Language.Syntactic as Syn

-- operational-higher.
import qualified Control.Monad.Operational.Higher as Oper

-- imperative-edsl.
import Language.Embedded.Imperative.Frontend.General hiding (Ref, Arr, IArr)
import qualified Language.Embedded.Imperative     as Imp
import qualified Language.Embedded.Imperative.CMD as Imp

-- hardware-edsl.
import qualified Language.Embedded.Hardware.Command.CMD as Hard

-- hmm!
import Feldspar.Hardware.Primitive  (HardwarePrimType(..), HardwarePrimTypeRep(..))
import Feldspar.Hardware.Expression (HType')
import Feldspar.Hardware.Frontend   (HSig, withHType')

import Prelude hiding (length, Word, (<=), (<), (>=), (>))
import qualified Prelude as P

--------------------------------------------------------------------------------
-- * Expressions.
--------------------------------------------------------------------------------

instance Value SExp
  where
    value = sugarSymSoftware . Lit

instance Share SExp
  where
    share = sugarSymSoftware (Let "")

instance Iterate SExp
  where
    loop = sugarSymSoftware ForLoop

instance Cond SExp
  where
    cond = sugarSymSoftware Cond

instance Equality SExp
  where
    (==) = sugarSymPrimSoftware Eq

instance Ordered SExp
  where
    (<)  = sugarSymPrimSoftware Lt
    (<=) = sugarSymPrimSoftware Lte
    (>)  = sugarSymPrimSoftware Gt
    (>=) = sugarSymPrimSoftware Gte

instance Logical SExp
  where
    not  = sugarSymPrimSoftware Not
    (&&) = sugarSymPrimSoftware And
    (||) = sugarSymPrimSoftware Or

instance Multiplicative SExp
  where
    mult = sugarSymPrimSoftware Mul
    div  = sugarSymPrimSoftware Div
    mod  = sugarSymPrimSoftware Mod

instance Bitwise SExp
  where
    complement = sugarSymPrimSoftware BitCompl
    (.&.) = sugarSymPrimSoftware BitAnd
    (.|.) = sugarSymPrimSoftware BitOr
    xor   = sugarSymPrimSoftware BitXor
    sll   = sugarSymPrimSoftware ShiftL
    srl   = sugarSymPrimSoftware ShiftR
    rol   = sugarSymPrimSoftware RotateL
    ror   = sugarSymPrimSoftware RotateR

instance Casting SExp
  where
    i2n = sugarSymPrimSoftware I2N
    i2b = sugarSymPrimSoftware I2B
    b2i = sugarSymPrimSoftware B2I

--------------------------------------------------------------------------------

instance (Bounded a, SType a) => Bounded (SExp a)
  where
    minBound = value minBound
    maxBound = value maxBound

instance (Num a, SType' a) => Num (SExp a)
  where
    fromInteger = value . fromInteger
    (+)         = sugarSymPrimSoftware Add
    (-)         = sugarSymPrimSoftware Sub
    (*)         = sugarSymPrimSoftware Mul
    negate      = sugarSymPrimSoftware Neg
    abs         = error "todo: abs not implemeted for `SExp`"
    signum      = error "todo: signum not implemented for `SExp`"

instance (Fractional a, SType' a) => Fractional (SExp a)
  where
    fromRational = value . fromRational
    (/)          = sugarSymPrimSoftware FDiv

instance (Floating a, SType' a) => Floating (SExp a)
  where
    pi    = sugarSymPrimSoftware Pi
    exp   = sugarSymPrimSoftware Exp
    log   = sugarSymPrimSoftware Log
    sqrt  = sugarSymPrimSoftware Sqrt
    (**)  = sugarSymPrimSoftware Pow
    sin   = sugarSymPrimSoftware Sin
    cos   = sugarSymPrimSoftware Cos
    tan   = sugarSymPrimSoftware Tan
    asin  = sugarSymPrimSoftware Asin
    acos  = sugarSymPrimSoftware Acos
    atan  = sugarSymPrimSoftware Atan
    sinh  = sugarSymPrimSoftware Sinh
    cosh  = sugarSymPrimSoftware Cosh
    tanh  = sugarSymPrimSoftware Tanh
    asinh = sugarSymPrimSoftware Asinh
    acosh = sugarSymPrimSoftware Acosh
    atanh = sugarSymPrimSoftware Atanh

--------------------------------------------------------------------------------

complex :: (Num a, SType' a, SType' (Complex a)) =>
  SExp a -> -- ^ Real
  SExp a -> -- ^ Imaginary
  SExp (Complex a)
complex = sugarSymPrimSoftware Complex

polar :: (Floating a, SType' a, SType' (Complex a)) =>
  SExp a -> -- ^ Magnitude
  SExp a -> -- ^ Phase
  SExp (Complex a)
polar = sugarSymPrimSoftware Polar

real :: (SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a
real = sugarSymPrimSoftware Real

imaginary :: (SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a
imaginary = sugarSymPrimSoftware Imag

magnitude :: (RealFloat a, SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a
magnitude = sugarSymPrimSoftware Magnitude

phase :: (RealFloat a, SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a
phase = sugarSymPrimSoftware Phase

conjugate :: (RealFloat a, SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp (Complex a)
conjugate = sugarSymPrimSoftware Conjugate

ilog2 :: (FiniteBits a, Integral a, SType' a) => SExp a -> SExp a
ilog2 a = snd $ P.foldr (\ffi vr -> share vr (step ffi)) (a,0) ffis
  where
    step (ff,i) (v,r) = share (b2i (v > fromInteger ff) .<<. value i) $ \shift ->
      (v .>>. i2n shift, r .|. shift)

    -- [(0x1, 0), (0x3, 1), (0xF, 2), (0xFF, 3), (0xFFFF, 4), ...]
    ffis = (`P.zip` [0..])
         $ P.takeWhile (P.<= (2 P.^ (bitSize a `P.div` 2) - 1 :: Integer))
         $ P.map ((subtract 1) . (2 P.^) . (2 P.^))
         $ [(0::Integer)..]
    -- Based on: http://graphics.stanford.edu/~seander/bithacks.html#IntegerLog

--------------------------------------------------------------------------------

foreignImport
  :: ( Syn.Signature sig
     , fi  ~ Syn.SmartFun dom sig
     , sig ~ Syn.SmartSig fi
     , dom ~ Syn.SmartSym fi
     , dom ~ SoftwareDomain
     , Syn.SyntacticN f fi
     , Type SoftwarePrimType (Syn.DenResult sig)
     )
  => String -> Denotation sig -> f
foreignImport str f = sugarSymSoftware (Construct str f)

--------------------------------------------------------------------------------
-- * Instructions.
--------------------------------------------------------------------------------

desugar :: (Syntactic a, Domain a ~ SoftwareDomain) => a -> SExp (Internal a)
desugar = SExp . Syn.desugar

sugar   :: (Syntactic a, Domain a ~ SoftwareDomain) => SExp (Internal a) -> a
sugar   = Syn.sugar . unSExp

resugar
  :: ( Syntactic a
     , Syntactic b
     , Internal a ~ Internal b
     , Domain a   ~ SoftwareDomain
     , Domain b   ~ SoftwareDomain
     )
  => a -> b
resugar = Syn.resugar

--------------------------------------------------------------------------------

instance References Software
  where
    type Reference Software = Ref
    initRef = Software . fmap Ref . mapStructA (Imp.initRef) . resugar
    newRef  = Software . fmap Ref . mapStructA (const Imp.newRef) $ typeRep
    getRef  = Software . fmap resugar . mapStructA getRef' . unRef
    setRef ref
      = Software
      . sequence_
      . zipListStruct setRef' (unRef ref)
      . resugar
    unsafeFreezeRef
      = Software
      . fmap resugar
      . mapStructA freezeRef'
      . unRef

-- Imp.getRef specialized to software.
getRef' :: forall b . SoftwarePrimType b => Imp.Ref b -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) (SExp b)
getRef' = withSType (Proxy :: Proxy b) Imp.getRef

-- Imp.setRef specialized to software.
setRef' :: forall b . SoftwarePrimType b => Imp.Ref b -> SExp b -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) ()
setRef' = withSType (Proxy :: Proxy b) Imp.setRef

-- 'Imp.unsafeFreezeRef' specialized to software.
freezeRef' :: forall b . SoftwarePrimType b => Imp.Ref b -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) (SExp b)
freezeRef' = withSType (Proxy :: Proxy b) Imp.unsafeFreezeRef

--------------------------------------------------------------------------------

instance Slicable SExp (Arr a)
  where
    slice from len (Arr o l arr) = Arr (o+from) len arr

instance Finite SExp (Arr a)
  where
    length = arrLength

instance Arrays Software
  where
    type Array Software = Arr
    newArr len
      = Software
      $ fmap (Arr 0 len)
      $ mapStructA (const (Imp.newArr len))
      $ typeRep
    initArr elems
      = Software
      $ fmap (Arr 0 len . Node)
      $ Imp.constArr elems
      where len = value $ genericLength elems
    getArr arr ix
      = Software
      $ fmap resugar
      $ mapStructA (flip getArr' (ix + arrOffset arr))
      $ unArr arr
    setArr arr ix a
      = Software
      $ sequence_
      $ zipListStruct
         (\a' arr' -> setArr' arr' (ix + arrOffset arr) a')
         (resugar a)
      $ unArr arr
    copyArr arr brr
      = Software
      $ sequence_
      $ zipListStruct (\a b ->
          Imp.copyArr (a, arrOffset arr) (b, arrOffset brr) (length brr))
        (unArr arr)
        (unArr brr)

-- 'Imp.getArr' specialized to software.
getArr' :: forall b . SoftwarePrimType b
  => Imp.Arr Index b -> SExp Index
  -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) (SExp b)
getArr' = withSType (Proxy :: Proxy b) Imp.getArr

-- 'Imp.setArr' specialized to software.
setArr' :: forall b . SoftwarePrimType b
  => Imp.Arr Index b -> SExp Index -> SExp b
  -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) ()
setArr' = withSType (Proxy :: Proxy b) Imp.setArr

--------------------------------------------------------------------------------

instance Syntax SExp a => Indexed SExp (IArr a)
  where
    type ArrElem (IArr a) = a
    (!) (IArr off len a) ix = resugar $ mapStruct index a
      where
        index :: forall b . SoftwarePrimType b => Imp.IArr Index b -> SExp b
        index arr = sugarSymPrimSoftware
          (GuardVal InternalAssertion "arrIndex: index out of bounds.")
          (ix < len)
          (sugarSymPrimSoftware (ArrIx arr) (ix + off) :: SExp b)

instance Slicable SExp (IArr a)
  where
    slice from len (IArr o l arr) = IArr (o+from) len arr

instance Finite SExp (IArr a)
  where
    length = iarrLength

instance IArrays Software
  where
    type IArray Software = IArr
    unsafeFreezeArr arr
      = Software
      $ fmap (IArr (arrOffset arr) (length arr))
      $ mapStructA (Imp.unsafeFreezeArr)
      $ unArr arr
    unsafeThawArr iarr
      = Software
      $ fmap (Arr (iarrOffset iarr) (length iarr))
      $ mapStructA (Imp.unsafeThawArr)
      $ unIArr iarr

--------------------------------------------------------------------------------

-- | Short-hand for software pull vectors.
type SPull a = Pull SExp a

-- | Short-hand for software push vectors.
type SPush a = Push Software a

-- | Short-hand for software manifest vectors.
type SManifest a = Manifest Software a

instance Syntax SExp (SExp a) => Pushy Software (IArr (SExp a)) (SExp a)
  where
    toPush iarr = toPush (M iarr :: Manifest Software (SExp a))

instance ViewManifest Software (IArr (SExp a)) (SExp a)
  where
    viewManifest = Just . M

instance Manifestable Software (IArr (SExp a)) (SExp a)

instance ArraysSwap Software
  where
    unsafeArrSwap arr brr = Software $ sequence_ $ zipListStruct Imp.unsafeSwapArr
      (unArr arr)
      (unArr brr)

--------------------------------------------------------------------------------

instance Control Software
  where
    iff c t f
      = Software
      $ Imp.iff (resugar c)
          (unSoftware t)
          (unSoftware f)

instance Loop Software
  where
    while c body
      = Software
      $ Imp.while
          (fmap resugar $ unSoftware c)
          (unSoftware body)
    for lower step upper body
      = Software
      $ Imp.for
          (resugar lower, step, Imp.Incl $ resugar upper)
          (unSoftware . body . resugar)

instance Assert Software
  where
    assert = assertLabel $ UserAssertion ""

assertLabel :: AssertionLabel -> SExp Bool -> String -> Software ()
assertLabel lbl cond msg = Software $ Oper.singleInj $ Assert lbl cond msg

--------------------------------------------------------------------------------
-- ** Software instructions.
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- *** Assertions.

guard :: Syntax SExp a => SExp Bool -> String -> a -> a
guard = guardLabel $ UserAssertion ""

guardLabel :: Syntax SExp a => AssertionLabel -> SExp Bool -> String -> a -> a
guardLabel lbl cond msg = sugarSymSoftware (GuardVal lbl msg) cond

hint :: (Syntax SExp a, Syntax SExp b, Primitive SExp (Internal a))
  => a -- ^ Value to be used in invariant.
  -> b -- ^ Result value.
  -> b
hint x y = sugarSymSoftware HintVal x y

--------------------------------------------------------------------------------
-- *** File handling.

-- | Open a file.
fopen :: FilePath -> IOMode -> Software Handle
fopen file = Software . Imp.fopen file

-- | Close a file.
fclose :: Handle -> Software ()
fclose = Software . Imp.fclose

-- | Check for end of file.
feof :: Handle -> Software (SExp Bool)
feof = Software . Imp.feof

-- | Put a primitive value to a handle.
fput :: (Formattable a, SType' a)
    => Handle
    -> String  -- ^ Prefix.
    -> SExp a  -- ^ Expression to print.
    -> String  -- ^ Suffix.
    -> Software ()
fput h pre e post = Software $ Imp.fput h pre e post

-- | Get a primitive value from a handle.
fget :: (Formattable a, SType' a) => Handle -> Software (SExp a)
fget = Software . Imp.fget

-- | Handle to \stdin\.
stdin :: Handle
stdin = Imp.stdin

-- | Handle to \stdout\.
stdout :: Handle
stdout = Imp.stdout

--------------------------------------------------------------------------------
-- *** Printing.

class PrintfType r
  where
    fprf :: Handle -> String -> [Imp.PrintfArg SExp SoftwarePrimType] -> r

instance (a ~ ()) => PrintfType (Software a)
  where
    fprf h form = Software . Oper.singleInj . Imp.FPrintf h form . reverse

instance (Formattable a, SType' a, PrintfType r) => PrintfType (SExp a -> r)
  where
    fprf h form as = \a -> fprf h form (Imp.PrintfArg a : as)

-- | Print to a handle. Accepts a variable number of arguments.
fprintf :: PrintfType r => Handle -> String -> r
fprintf h format = fprf h format []

-- | Print to @stdout@. Accepts a variable number of arguments.
printf :: PrintfType r => String -> r
printf = fprintf Imp.stdout

--------------------------------------------------------------------------------
-- *** Memory.

-- | Software argument specialized to software primitives.
type SArg = Argument SoftwarePrimType

-- | Establish a memory-mapping to a hardware signature.
mmap :: String -> HSig a -> Software (Address a)
mmap address sig =
  do pointer <- Software $ Oper.singleInj $ MMap address sig
     return $ Address pointer sig

-- | Call a memory-mapped component.
call :: Address a -> SArg (Soften a) -> Software ()
call address arg = Software $ Oper.singleInj $ Call address arg

-- | ...
nil :: SArg ()
nil = Nil

-- | ...
(>:) :: forall a b . (SType' a, HType' a, Integral a)
  => Ref (SExp a) -> SArg b -> SArg (Ref (SExp a) -> b)
(>:) = withHType' (Proxy :: Proxy a) ARef

(>.) :: forall a b . (SType' a, HType' a, Integral a)
  => SExp a -> SArg b -> SArg (Ref (SExp a) -> b)
(>.) v = undefined

-- | ...
(>>:) :: forall a b . (SType' a, HType' a, Integral a)
  => Arr (SExp a) -> SArg b -> SArg (Arr (SExp a) -> b)
(>>:) = withHType' (Proxy :: Proxy a) AArr

(>>.) :: forall a b . (SType' a, HType' a, Integral a)
  => IArr (SExp a) -> SArg b -> SArg (Arr (SExp a) -> b)
(>>.) = undefined

infixr 1 >:, >>:

--------------------------------------------------------------------------------
-- *** C specific.

-- | Create a null pointer
newPtr :: SType' a => Software (Ptr a)
newPtr = newNamedPtr "p"

-- | Create a named null pointer
--
-- The provided base name may be appended with a unique identifier to avoid name
-- collisions.
newNamedPtr :: SType' a => String -> Software (Ptr a)
newNamedPtr = Software . Imp.newNamedPtr

-- | Cast a pointer to an array
ptrToArr :: SType' a => Ptr a -> SExp Length -> Software (Arr (SExp a))
ptrToArr ptr len = fmap (Arr 0 len . Node) $ Software $ Imp.ptrToArr ptr

-- | Create a pointer to an abstract object. The only thing one can do with such
-- objects is to pass them to 'callFun' or 'callProc'.
newObject
    :: String  -- ^ Object type
    -> Bool    -- ^ Pointed?
    -> Software Object
newObject = newNamedObject "obj"

-- | Create a pointer to an abstract object. The only thing one can do with such
-- objects is to pass them to 'callFun' or 'callProc'.
--
-- The provided base name may be appended with a unique identifier to avoid name
-- collisions.
newNamedObject
    :: String  -- ^ Base name
    -> String  -- ^ Object type
    -> Bool    -- ^ Pointed?
    -> Software Object
newNamedObject base t p = Software $ Imp.newNamedObject base t p

-- | Add an @#include@ statement to the generated code
addInclude :: String -> Software ()
addInclude = Software . Imp.addInclude

-- | Add a global definition to the generated code
--
-- Can be used conveniently as follows:
--
-- > {-# LANGUAGE QuasiQuotes #-}
-- >
-- > import Feldspar.IO
-- >
-- > prog = do
-- >     ...
-- >     addDefinition myCFunction
-- >     ...
-- >   where
-- >     myCFunction = [cedecl|
-- >       void my_C_function( ... )
-- >       {
-- >           // C code
-- >           // goes here
-- >       }
-- >       |]
addDefinition :: Imp.Definition -> Software ()
addDefinition = Software . Imp.addDefinition

-- | Declare an external function
addExternFun :: SType' res
    => String    -- ^ Function name
    -> proxy res -- ^ Proxy for expression and result type
    -> [FunArg SExp SoftwarePrimType]
                 -- ^ Arguments (only used to determine types)
    -> Software ()
addExternFun fun res args = Software $ Imp.addExternFun fun res args

-- | Declare an external procedure
addExternProc
    :: String -- ^ Procedure name
    -> [FunArg SExp SoftwarePrimType]
              -- ^ Arguments (only used to determine types)
    -> Software ()
addExternProc proc args = Software $ Imp.addExternProc proc args

-- | Call a function
callFun :: SType' a
    => String -- ^ Function name
    -> [FunArg SExp SoftwarePrimType]
              -- ^ Arguments
    -> Software (SExp a)
callFun fun as = Software $ Imp.callFun fun as

-- | Call a procedure
callProc
    :: String -- ^ Function name
    -> [FunArg SExp SoftwarePrimType]
              -- ^ Arguments
    -> Software ()
callProc fun as = Software $ Imp.callProc fun as

-- | Call a procedure and assign its result
callProcAssign :: Assignable obj
    => obj    -- ^ Object to which the result should be assigned
    -> String -- ^ Procedure name
    -> [FunArg SExp SoftwarePrimType]
              -- ^ Arguments
    -> Software ()
callProcAssign obj fun as = Software $ Imp.callProcAssign obj fun as

-- | Declare and call an external function
externFun :: SType' res
    => String -- ^ Procedure name
    -> [FunArg SExp SoftwarePrimType]
              -- ^ Arguments
    -> Software (SExp res)
externFun fun args = Software $ Imp.externFun fun args

-- | Declare and call an external procedure
externProc
    :: String -- ^ Procedure name
    -> [FunArg SExp SoftwarePrimType]
              -- ^ Arguments
    -> Software ()
externProc proc args = Software $ Imp.externProc proc args

-- | Generate code into another translation unit
inModule :: String -> Software () -> Software ()
inModule mod = Software . Imp.inModule mod . unSoftware

-- | Get current time as number of seconds passed today
getTime :: Software (SExp Double)
getTime = Software Imp.getTime

-- | Constant string argument
strArg :: String -> FunArg SExp SoftwarePrimType
strArg = Imp.strArg

-- | Value argument
valArg :: SoftwarePrimType a => SExp a -> FunArg SExp SoftwarePrimType
valArg = Imp.valArg

-- | Reference argument
refArg :: SoftwarePrimType (Internal a) => Ref a -> FunArg SExp SoftwarePrimType
refArg (Ref r) = Imp.refArg (extractNode r)

-- | Mutable array argument
arrArg :: SoftwarePrimType (Internal a) => Arr a -> FunArg SExp SoftwarePrimType
arrArg (Arr o _ a) = Imp.offset (Imp.arrArg (extractNode a)) o

-- | Immutable array argument
iarrArg :: SoftwarePrimType (Internal a) => IArr a -> FunArg SExp SoftwarePrimType
iarrArg (IArr o _ a) = Imp.offset (Imp.iarrArg (extractNode a)) o

-- | Abstract object argument
objArg :: Object -> FunArg SExp SoftwarePrimType
objArg = Imp.objArg

-- | Named constant argument
constArg
    :: String  -- ^ Type
    -> String  -- ^ Named constant
    -> FunArg SExp SoftwarePrimType
constArg = Imp.constArg

-- | Modifier that takes the address of another argument
addr :: FunArg SExp SoftwarePrimType -> FunArg SExp SoftwarePrimType
addr = Imp.addr

-- | Modifier that dereferences another argument
deref :: FunArg SExp SoftwarePrimType -> FunArg SExp SoftwarePrimType
deref = Imp.deref

--------------------------------------------------------------------------------
--
--------------------------------------------------------------------------------

-- Swap an `Imp.FreePred` constraint with a `SoftwarePrimType` one.
withSType :: forall a b . Proxy a
  -> (Imp.FreePred SExp a => b)
  -> (SoftwarePrimType  a => b)
withSType _ f = case predicateDict (softwareRep :: SoftwarePrimTypeRep a) of
  Dict -> f

-- Proves that a type from `SoftwarePrimTypeRep` satisfies `Imp.FreePred`.
predicateDict :: SoftwarePrimTypeRep a -> Dict (Imp.FreePred SExp a)
predicateDict rep = case rep of
  BoolST   -> Dict
  Int8ST   -> Dict
  Int16ST  -> Dict
  Int32ST  -> Dict
  Int64ST  -> Dict
  Word8ST  -> Dict
  Word16ST -> Dict
  Word32ST -> Dict
  Word64ST -> Dict
  FloatST  -> Dict
  ComplexFloatST  -> Dict
  ComplexDoubleST -> Dict

--------------------------------------------------------------------------------

max_stars_repo_name: markus-git/co-feldspar

max_issues_repo_name: markus-git/co-feldspar

max_forks_repo_name: markus-git/co-feldspar


text:
module Network.Network.SOM
( SOM(..)

) where

import Network.Neuron
import Network.Layer
import Network.Network

import Numeric.LinearAlgebra

data SOM = SOM { map :: Matrix (Vector Double) }

instance Network (SOM) where
  predict inputs network = inputs

  createNetwork transformation g defs = SOM $ fromLists [[fromList [1.0] :: Vector Double]]

max_stars_repo_name: AkatsukiSirius/LambdaNet

max_issues_repo_name: world-admin/LambdaNet

max_forks_repo_name: world-admin/LambdaNet


text:
{- HLINT ignore "Evaluate" -}

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2021 IOHK
-- License: Apache-2.0
--
-- Provides functions for selecting coins for use as collateral from a UTxO
-- set.
--
-- See the documentation for 'performSelection' for more details.
--
module Cardano.Wallet.CoinSelection.Internal.Collateral
    (
    -- * Public API

      performSelection
    , PerformSelection
    , PerformSelectionOf
    , SelectionConstraints (..)
    , SelectionParams
    , SelectionParamsOf (..)
    , SelectionResult
    , SelectionResultOf (..)
    , selectionResultEmpty
    , SelectionCollateralError
    , SelectionCollateralErrorOf (..)
    , SearchSpaceLimit (..)
    , searchSpaceLimitDefault

    -- * Internal API

    -- ** Selecting collateral by giving priority to smallest values first
    , selectCollateralSmallest

    -- ** Selecting collateral by giving priority to largest values first
    , selectCollateralLargest

    -- ** Guarding search space size
    , SearchSpaceRequirement (..)
    , guardSearchSpaceSize

    -- ** Generating submaps
    , submaps

    -- ** Generating subsequences
    , subsequencesOfSize
    , numberOfSubsequencesOfSize

    -- ** Control flow
    , firstRight
    , takeUntil
    )
    where

import Cardano.Wallet.Primitive.Types.Coin
    ( Coin )
import Cardano.Wallet.Primitive.Types.Tx
    ( TxIn )
import Data.Function
    ( (&) )
import Data.IntCast
    ( intCast, intCastMaybe )
import Data.List.NonEmpty
    ( NonEmpty )
import Data.Map.Strict
    ( Map )
import Data.Maybe
    ( listToMaybe, mapMaybe )
import Data.Ord
    ( Down (..) )
import Data.Semigroup
    ( sconcat )
import Data.Set
    ( Set )
import GHC.Generics
    ( Generic )

import Prelude

import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Math.Combinatorics.Exact.Binomial as MathExact
import qualified Numeric.SpecFunctions as MathFast

--------------------------------------------------------------------------------
-- Public API
--------------------------------------------------------------------------------

-- | The type of all functions that perform selections.
--
type PerformSelectionOf inputId =
    SelectionConstraints ->
    SelectionParamsOf inputId ->
    Either (SelectionCollateralErrorOf inputId) (SelectionResultOf inputId)

-- | The default type for 'PerformSelectionOf'.
--
type PerformSelection = PerformSelectionOf TxIn

-- | Specifies all constraints required for collateral selection.
--
-- Selection constraints:
--
--    - are dependent on the current set of protocol parameters.
--
--    - are not specific to a given selection.
--
--    - place limits on the selection algorithm, enabling it to produce
--      selections that are acceptable to the ledger.
--
data SelectionConstraints = SelectionConstraints
    { maximumSelectionSize
        :: Int
        -- ^ An upper bound on the number of unique coins that can be selected
        -- as collateral.
    , searchSpaceLimit
        :: SearchSpaceLimit
        -- ^ An upper bound on the search space size, to protect the wallet
        -- against computations that use excessive amounts of time or space.
    }
    deriving (Eq, Generic, Show)

-- | Specifies all parameters that are specific to a given selection.
--
data SelectionParamsOf inputId = SelectionParams
    { coinsAvailable
        :: Map inputId Coin
        -- ^ The set of all coins available for selection as collateral.
    , minimumSelectionAmount
        :: Coin
        -- ^ A lower bound on the sum of coins to be selected as collateral.
    }
    deriving (Eq, Generic, Show)

-- | The default type for 'SelectionParamsOf'.
--
type SelectionParams = SelectionParamsOf TxIn

-- | Specifies an upper bound on the search space size.
--
data SearchSpaceLimit
    = SearchSpaceLimit Int
    -- ^ Specifies an upper bound on the number of coin combinations that can
    -- be considered in any single step.
    | UnsafeNoSearchSpaceLimit
    -- ^ Specifies that there is no search space limit. This should only be
    -- used for testing purposes.
    deriving (Eq, Show)

-- | The default search space limit.
--
-- This constant is used by the test suite, so we can be reasonably confident
-- that performing selections with this limit will not use inordinate amounts
-- of time and space.
--
searchSpaceLimitDefault :: SearchSpaceLimit
searchSpaceLimitDefault = SearchSpaceLimit 1_000_000

-- | Represents a successful selection of collateral.
--
newtype SelectionResultOf inputId = SelectionResult
    { coinsSelected :: Map inputId Coin
        -- ^ The coins that were selected for collateral.
    }
    deriving (Eq, Generic, Show)

-- | The default type for 'SelectionResultOf'.
--
type SelectionResult = SelectionResultOf TxIn

-- | A completely empty result, with no inputs selected.
--
selectionResultEmpty :: SelectionResultOf inputId
selectionResultEmpty = SelectionResult
    { coinsSelected = Map.empty
    }

-- | Represents an unsuccessful attempt to select collateral.
--
data SelectionCollateralErrorOf inputId = SelectionCollateralError
    { largestCombinationAvailable :: Map inputId Coin
        -- ^ The largest combination of coins available.
    , minimumSelectionAmount :: Coin
        -- ^ A lower bound on the sum of coins to be selected as collateral.
    }
    deriving (Eq, Generic, Show)

-- | The default type for `SelectionCollateralErrorOf`.
--
type SelectionCollateralError = SelectionCollateralErrorOf TxIn

-- | Selects coins for collateral.
--
-- This function tries two strategies in the following order, picking the first
-- strategy that succeeds:
--
--    1. Attempt to select an amount of collateral that is as small as possible.
--    2. Attempt to select collateral from the largest coins available.
--
-- The first strategy, given unlimited computation time, will always produce an
-- optimal result: the smallest possible amount of collateral. However, if the
-- required search space is large, and if the 'searchSpaceLimit' parameter is
-- set to a value that's smaller than the required search space size, then this
-- strategy will fail without computing a result.
--
-- The second strategy sacrifices optimality and always produces a result if
-- one is available, by looking only at the very largest coins available. This
-- result can be computed very quickly, without using much search space.
--
-- The combination of these two strategies means that we can satisfy the
-- following properties:
--
-- If the attempt to select collateral succeeds:
--
--    >>> sum  coinsSelected ≥ minimumSelectionAmount
--    >>> size coinsSelected ≤ maximumSelectionSize
--    >>>      coinsSelected ⊆ coinsAvailable
--
-- If the attempt to select collateral fails:
--
--    >>> sum  largestCombinationAvailable < minimumSelectionAmount
--    >>> size largestCombinationAvailable ≤ maximumSelectionSize
--    >>>      largestCombinationAvailable ⊆ coinsAvailable
--
performSelection :: forall inputId. Ord inputId => PerformSelectionOf inputId
performSelection constraints =
    firstRight $ fmap ($ constraints)
        [ selectCollateralSmallest
        , selectCollateralLargest
        ]

--------------------------------------------------------------------------------
-- Internal API
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- Selecting collateral by giving priority to smallest values first
--------------------------------------------------------------------------------

-- | Attempts to select an amount of collateral that is as small as possible.
--
-- This function, given unlimited computation time, will always produce an
-- optimal result: the smallest possible amount of collateral. However, if the
-- required search space is large, and if the 'searchSpaceLimit' parameter is
-- set to a value that's smaller than the required search space size, then this
-- function will return without computing a result.
--
selectCollateralSmallest
    :: forall inputId. Ord inputId => PerformSelectionOf inputId
selectCollateralSmallest constraints params =
    case smallestValidCombination of
        Just coinsSelected ->
            Right SelectionResult {coinsSelected}
        Nothing ->
            Left SelectionCollateralError
                { largestCombinationAvailable = mempty
                , minimumSelectionAmount
                }
  where
    coinsToConsider :: [(inputId, Coin)]
    coinsToConsider = coinsAvailable
        & Map.toList
        & L.sortOn snd
        & takeUntil ((>= minimumSelectionAmount) . snd)

    numberOfCoinsToConsider :: Int
    numberOfCoinsToConsider = length coinsToConsider

    smallestValidCombination :: Maybe (Map inputId Coin)
    smallestValidCombination =
        listToMaybe $ L.sortOn F.fold validCombinations
      where
        validCombinations :: [Map inputId Coin]
        validCombinations =
            mapMaybe smallestValidCombinationOfSize
            [1 .. maximumSelectionSize]

    smallestValidCombinationOfSize :: Int -> Maybe (Map inputId Coin)
    smallestValidCombinationOfSize size =
        guardSearchSpaceSize searchSpaceRequirement searchSpaceLimit result
      where
        result :: Maybe (Map inputId Coin)
        result = coinsToConsider
            & (`subsequencesOfSize` size)
            & fmap (\ics -> (ics, F.foldMap snd ics))
            & L.sortOn snd
            & L.dropWhile ((< minimumSelectionAmount) . snd)
            & listToMaybe
            & fmap (Map.fromList . fst)

        searchSpaceRequirement :: SearchSpaceRequirement
        searchSpaceRequirement = maybe
            SearchSpaceRequirementUnknown
            SearchSpaceRequirement
            (numberOfCoinsToConsider `numberOfSubsequencesOfSize` size)

    SelectionConstraints
        { maximumSelectionSize
        , searchSpaceLimit
        } = constraints
    SelectionParams
        { coinsAvailable
        , minimumSelectionAmount
        } = params

--------------------------------------------------------------------------------
-- Selecting collateral by giving priority to largest values first
--------------------------------------------------------------------------------

-- | Selects collateral from the largest coins available.
--
-- This function sacrifices optimality and always produces a result if one is
-- available, by looking only at the very largest coins available.
--
-- This result can be computed very quickly, without using much search space.
--
selectCollateralLargest
    :: forall inputId. Ord inputId => PerformSelectionOf inputId
selectCollateralLargest constraints params =
    case smallestValidSubmapOfLargestCombinationAvailable of
        Just coinsSelected ->
            Right SelectionResult {coinsSelected}
        Nothing ->
            Left SelectionCollateralError
                { largestCombinationAvailable
                , minimumSelectionAmount
                }
  where
    largestCombinationAvailable :: Map inputId Coin
    largestCombinationAvailable =
        coinsAvailable
            & Map.toList
            & L.sortOn (Down . snd)
            & L.take maximumSelectionSize
            & Map.fromList

    smallestValidSubmapOfLargestCombinationAvailable :: Maybe (Map inputId Coin)
    smallestValidSubmapOfLargestCombinationAvailable =
        largestCombinationAvailable
            & submaps
            & Set.toList
            & fmap (\ics -> (ics, F.fold ics))
            & L.sortOn snd
            & L.dropWhile ((< minimumSelectionAmount) . snd)
            & fmap fst
            & listToMaybe

    SelectionConstraints
        { maximumSelectionSize
        } = constraints
    SelectionParams
        { coinsAvailable
        , minimumSelectionAmount
        } = params

--------------------------------------------------------------------------------
-- Generating submaps
--------------------------------------------------------------------------------

-- | Generates all submaps of a given map.
--
-- This function is analogous to 'Set.powerSet'.
--
-- For a map 'm' of size 'n', this function will generate all possible submaps,
-- including the empty map and the original map 'm'.
--
submaps :: forall a b. (Ord a, Ord b) => Map a b -> Set (Map a b)
submaps m = Set.map (Map.restrictKeys m) (Set.powerSet (Map.keysSet m))

--------------------------------------------------------------------------------
-- Guarding search space size
--------------------------------------------------------------------------------

data SearchSpaceRequirement
    = SearchSpaceRequirement Int
      -- ^ Indicates a known search space requirement.
    | SearchSpaceRequirementUnknown
      -- ^ Indicates that the search space requirement is unknown.

guardSearchSpaceSize
    :: SearchSpaceRequirement
    -- ^ The search space requirement
    -> SearchSpaceLimit
    -- ^ The search space limit
    -> Maybe a
    -- ^ A computation that potentially yields a value
    -> Maybe a
    -- ^ The guarded computation
guardSearchSpaceSize requirement limit =
    case requirement of
        -- When the search space requirement is unknown, err on the side of
        -- caution and avoid evaluating the computation, unless the caller
        -- has explicitly specified that there is no limit:
        SearchSpaceRequirementUnknown ->
            case limit of
                SearchSpaceLimit _       -> const Nothing
                UnsafeNoSearchSpaceLimit -> id
        -- When the search space requirement is known, only evaluate the
        -- computation if the requirement is not greater than the limit:
        SearchSpaceRequirement r ->
            case limit of
                SearchSpaceLimit l | l < r -> const Nothing
                SearchSpaceLimit _         -> id
                UnsafeNoSearchSpaceLimit   -> id

--------------------------------------------------------------------------------
-- Generating subsequences
--------------------------------------------------------------------------------

-- | Computes the number of subsequences generated by 'subsequencesOfSize'.
--
-- This function can be used to determine whether calling 'subsequencesOfSize'
-- would use an excessive amount of time and space, and if so, avoid calling
-- it.
--
-- Returns 'Nothing' if the result is larger than 'maxBound :: Int'.
--
numberOfSubsequencesOfSize
    :: Int
    -- ^ Indicates the size of the sequence.
    -> Int
    -- ^ Indicates the size of subsequences.
    -> Maybe Int
numberOfSubsequencesOfSize n k
    | k <  0 || n <   0      = Nothing
    | k == 0 || k ==  n      = Just 1
    | k == 1 || k == (n - 1) = Just n
    | resultOutOfBounds      = Nothing
    | otherwise              = intCastMaybe resultExact
  where
    resultExact :: Integer
    resultExact = MathExact.choose
        (intCast @Int @Integer n)
        (intCast @Int @Integer k)

    resultFast :: Integer
    resultFast = floor (MathFast.choose n k)

    resultOutOfBounds :: Bool
    resultOutOfBounds = False
        || resultFast  < 0
        || resultFast  > intCast @Int @Integer (maxBound @Int)
        || resultExact < 0
        || resultExact > intCast @Int @Integer (maxBound @Int)

-- | Generates all subsequences of size 'k' from a particular sequence.
--
-- Warning: this function can use an excessive amount of time and space.
--
-- To check how many results would be returned without actually generating
-- them, use the 'numberOfSubsequencesOfSize' function.
--
-- Properties:
--
--    >>> all (== k) (length <$> xs `subsequencesOfSize` k)
--
--    >>> length (xs `subsequencesOfSize` k) ==
--    >>>     length xs `numberOfSubsequencesOfSize` k
--
subsequencesOfSize
    :: [a]
    -- ^ The sequence from which to generate subsequences.
    -> Int
    -- ^ The size 'k' of subsequences to generate.
    -> [[a]]
    -- ^ All subsequences of size 'k'.
subsequencesOfSize xs k
    | k <= 0 =
        []
    | k > length xs =
        []
    | otherwise =
        case drop k (subsequencesBySize xs) of
            result : _ -> result
            [] -> []
  where
    subsequencesBySize [] = [[[]]]
    subsequencesBySize (y : ys) =
        zipWith
            (++)
            ([] : map (map (y :)) next)
            (next ++ [[]])
      where
        next = subsequencesBySize ys

--------------------------------------------------------------------------------
-- Control flow
--------------------------------------------------------------------------------

-- | Applies a sequence of functions to an argument until one succeeds.
--
-- This function iterates through the specified sequence from left to right,
-- applying each function to the given argument, and returning the very first
-- 'Right' result encountered, without evaluating the subsequent functions.
--
-- If none of the given functions produces a 'Right' result, then this function
-- returns the 'Left' result produced by the last function in the sequence.
--
firstRight :: NonEmpty (a -> Either e r) -> (a -> Either e r)
firstRight = sconcat

-- | Takes items from a list until a predicate becomes true.
--
-- The returned list is a prefix of the original list, and includes the very
-- first item that satisfies the predicate.
--
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil p = foldr (\x ys -> x : if p x then [] else ys) []

max_stars_repo_name: runeksvendsen/cardano-wallet

max_issues_repo_name: cryptorites-scotti/cardano-wallet

max_forks_repo_name: cryptorites-scotti/cardano-wallet