text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Lib where
    -- ( someFunc
    -- ) where

import Statistics.Distribution (probability)
import Statistics.Distribution.Binomial (binomial)
import Data.List
import qualified Data.Map.Strict as Map
import qualified  Data.Text.Lazy as TL
import Web.Scotty as S
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty
import Text.Blaze.Internal (customAttribute)
import Network.Wai.Middleware.Static

import Data.Aeson
import GHC.Generics
import Views (indexPage)

someFunc :: IO ()
someFunc = scotty 5000 $ do
  middleware $ staticPolicy (noDots >-> addBase "Static")
  get "/" indexPage
  post "/data" postRoute

postRoute :: ActionM ()
postRoute = do
  shippy <- S.body
  maybeShip shippy

maybeShip param = let shippy = decode param :: Maybe Parameters
  in case (shippy) of
       (Just fleet) -> S.json $ calcFleet fleet
       Nothing -> S.json $ calcFleet testParam

data ShipPart = Empty
              | IonCannon
              | ElectronComputer
              | Hull
              | NuclearDrive
              | NuclearSource
              | PlasmaCannon
              | AntimatterCannon
              | PlasmaMissile
              | PositronComputer
              | GluonComputer
              | GaussShield
              | PhaseShield
              | ImprovedHull
              | FusionDrive
              | TachyonDrive
              | FusionSource
              | TachyonSource
              deriving (Show, Generic)

instance ToJSON ShipPart
instance FromJSON ShipPart

data Parameters = Parameters {ships :: [([ShipPart], Count)], enemyShield :: Count}
  deriving (Show, Generic)

instance ToJSON Parameters
instance FromJSON Parameters

partsToShip :: [ShipPart] -> Ship
partsToShip xs = foldr (\x acc -> sumShips acc (partToShip x)) (Ship 0 0 0 0 0) xs
  where sumShips (Ship i p a c m) (Ship i' p' a' c' m') =
          Ship {ions = i + i'
               , plasmas = p + p'
               , antis = a + a'
               , computers = c + c'
               , missiles = m + m'}

partToShip :: ShipPart -> Ship
partToShip IonCannon = Ship 1 0 0 0 0
partToShip ElectronComputer = Ship 0 0 0 1 0
partToShip PlasmaCannon = Ship 0 1 0 0 0
partToShip AntimatterCannon = Ship 0 0 1 0 0
partToShip PlasmaMissile = Ship 0 0 0 0 1
partToShip PositronComputer = Ship 0 0 0 2 0
partToShip GluonComputer = Ship 0 0 0 3 0
partToShip _ = Ship 0 0 0 0 0

type Damage = Int
type Dices = Int
type ToHit = Int
type Count = Int
type Percentage = Double

type ResMap = Map.Map Int Percentage

data Probability = Prob [(Damage, Percentage)] deriving Show
data Hits = Hits [(Count, Percentage)] deriving Show
type Damages = [(Damage, Percentage)]
data Results = Results {labels :: [Damage], probs:: [Percentage],
                        mprobs :: [Percentage]}
             deriving (Show, Generic)

instance ToJSON Results
instance FromJSON Results

testParam :: Parameters
testParam = Parameters {ships = [([IonCannon, IonCannon, ElectronComputer, Empty], 2),
                                 ([IonCannon, PlasmaCannon, Hull, Empty], 1)]
                       , enemyShield = 0}

data Ship = Ship {ions     :: Count,
                  plasmas  :: Count,
                  antis    :: Count,
                  computers:: ToHit,
                  missiles :: Count} deriving (Generic, Show)

instance ToJSON Ship

instance FromJSON Ship

type EnemyShields = Count

calcHits :: Dices -> ToHit -> Hits
calcHits k hit
  | k < 1 || hit < 1 || hit > 6 = Hits []
  | otherwise = Hits $ fmap (\x -> (x, probability binom x)) [0..k]
  where binom = binomial k p
        p     = if hit <= 2 then fromIntegral 5 /6 else fromIntegral (6 - hit + 1) / 6

calcDmgs :: Ship -> EnemyShields -> Damages
calcDmgs ship shield = combineDmgs [ionDmg,plasmaDmg,antiDmg]
  where ionDmg    = hitsToDmgs 1 $ calcHits (ions ship) toHit
        plasmaDmg = hitsToDmgs 2 $ calcHits (plasmas ship) toHit
        antiDmg = hitsToDmgs 4 $ calcHits (antis ship) toHit
        toHit | shield - (computers ship) > 0  = 6
              | otherwise = 6 - (computers ship) + shield

calcMissiles :: Ship -> EnemyShields -> Damages
calcMissiles ship shield = hitsToDmgs 2 $ calcHits (missiles ship * 2) toHit
  where toHit | shield - (computers ship) > 0  = 6
              | otherwise = 6 - (computers ship) + shield

hitsToDmgs :: Damage -> Hits -> Damages
hitsToDmgs d (Hits xs) = fmap (\x -> (fst x * d, snd x)) xs

combineDmgs :: [Damages] -> Damages
combineDmgs [] = []
combineDmgs dmgs = foldr1 combine dmgs
  where combine xs [] =  xs
        combine [] ys =  ys
        combine xs ys =  func <$> xs <*> ys
        func = \x y -> (fst x + (fst y), snd x * (snd y))

sortMerge :: Damages -> ResMap
sortMerge xs = foldr helper startMap xs
  where largest = foldr (\x acc -> if fst x > acc then fst x else acc) 0 xs
        startMap = Map.fromList [(k, 0::Percentage) | k<-[0..largest]]
        helper x acc = Map.insertWith (+) (fst x) (snd x) acc

calcFleet :: Parameters ->  Results
calcFleet (Parameters fleet shields) =
  Results {labels = labels', probs = probs', mprobs = mprobs'}
  where mergedShips = uncurry mergeShip <$> fmap (\x -> (partsToShip (fst x), snd x)) fleet
        cannonsDmgs = flip calcDmgs shields <$> mergedShips
        missileDmgs = flip calcMissiles shields <$> mergedShips
        otherDmgs = sortMerge $ combineDmgs cannonsDmgs
        misDmg = sortMerge $ combineDmgs missileDmgs
        len = Prelude.max (Map.size otherDmgs) (Map.size misDmg)
        labels' = [0..len - 1]
        probs' = Map.elems $ Map.map (*100) $ fillMap otherDmgs labels'
        mprobs' = Map.elems $ Map.map (*100) $ fillMap misDmg labels'

mergeShip :: Ship -> Count -> Ship
mergeShip ship k = Ship {ions = ions ship * k
                        , plasmas = plasmas ship * k
                        , antis = antis ship * k
                        , missiles = missiles ship * k
                        , computers = computers ship}

fillMap mp l = foldr fun mp l
  where fun x acc = if Map.notMember x mp then Map.insert x 0 acc else acc

max_stars_repo_name: traunio/eclipse-bg

max_issues_repo_name: traunio/eclipse-bg

max_forks_repo_name: traunio/eclipse-bg


text:
-- Copyright 2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# OPTIONS_GHC -Wall #-}
module LeastSquaresVoting
  ( vote
  ) where

import           Control.Arrow
import           Data.HashMap.Strict            ( HashMap )
import qualified Data.HashMap.Strict           as M
import           Data.Hashable                  ( Hashable(..) )
import           Data.List                      ( sortBy )
import           Data.Maybe                     ( fromMaybe )
import           Data.Monoid                    ( Sum(..) )
import           Data.Ord                       ( comparing )
import           Numeric.LinearAlgebra          ( (><)
                                                , Matrix
                                                , flatten
                                                , linearSolveSVD
                                                , toList
                                                )

import           Types

-- | Let _(u, v)_ be a pair of candidates in a voter's ordered list. This means
-- that the voter's intent is that _u_ is ideally ranked a unit _D_ (1V) higher
-- than _v_. When their potentials are _U_ and _V_, the difference from the intent
-- will be _(U-V)-1_.
--
-- The **heat** (corresponding to the heat dissipated by an electrical
-- resistor) is the square of the difference multiplied by a unit conductivity
-- _G_ (which represents the voter's ability to influence the outcome).
--
-- ((U-V)-D)^2 G.
--
-- Partial derivatives
--   d/dU ... =   2 G (U-V-D)
--   d/dV ... = - 2 G (U-V-D)
edge :: (Integral c, Num n) => c -> a -> a -> [(a, [(a, n)], n)]
edge count u v =
  let c = fromIntegral count
  in  [(u, [(u, c), (v, -c)], -c), (v, [(u, -c), (v, c)], c)]

newtype IndexedMonoid i m = IndexedMonoid (HashMap i m)
  deriving (Eq, Show, Read)

instance (Eq i, Hashable i, Semigroup m) => Semigroup (IndexedMonoid i m) where
  IndexedMonoid m1 <> IndexedMonoid m2 = IndexedMonoid $ M.unionWith (<>) m1 m2

instance (Eq i, Hashable i, Monoid m) => Monoid (IndexedMonoid i m) where
  mempty = IndexedMonoid M.empty

insert :: (Eq i, Hashable i, Semigroup m) => i -> m -> IndexedMonoid i m
insert i m = IndexedMonoid $ M.singleton i m

ilookup :: (Eq i, Hashable i, Monoid m) => i -> IndexedMonoid i m -> m
ilookup i (IndexedMonoid m) = fromMaybe mempty $ M.lookup i m

size :: (Hashable i) => IndexedMonoid i m -> Int
size (IndexedMonoid m) = M.size m

indices :: (Hashable i) => IndexedMonoid i m -> [i]
indices (IndexedMonoid m) = M.keys m

type LinearSystem a n = IndexedMonoid a (IndexedMonoid a (Sum n), (Sum n))

sumEdges :: (Hashable a, Eq a, Num n) => [(a, [(a, n)], n)] -> LinearSystem a n
sumEdges = foldMap
  (\(c, ls, r) -> insert c (foldMap (uncurry insert . second Sum) ls, Sum r))

equations
  :: (Hashable a, Eq a)
  => [a]
  -> LinearSystem a Double
  -> (Matrix Double, Matrix Double)
equations is m =
  ( (n >< n)
    [ getSum $ ilookup col (fst (ilookup row m)) | row <- is, col <- is ]
  , (n >< 1) [ getSum $ snd (ilookup row m) | row <- is ]
  )
  where n = size m

solve :: (Hashable a, Eq a) => LinearSystem a Double -> [(a, Double)]
solve m =
  sortBy (comparing snd)
    . zip is
    . toList
    . flatten
    . uncurry linearSolveSVD
    . equations is
    $ m
  where is = indices m

vote :: (Eq a, Hashable a, Integral n) => Prefs a n -> [(a, Double)]
vote (Prefs []) = []
vote (Prefs prefs@((_, cs) : _)) | null edges = zip cs (repeat 0)
                                 | otherwise  = solve . sumEdges $ edges
 where
  edges =
    [ e
    | (count, order) <- prefs
    , (u    , v    ) <- zip order (tail order)
    , e              <- edge count u v
    ]

ext: hs

max_stars_repo_name: ppetr/least-squares-electric-voting

max_issues_repo_name: ppetr/least-squares-electric-voting

max_forks_repo_name: ppetr/least-squares-electric-voting


text:
-- Filename: fft.hs
-- Created by: Daniel Winograd-Cort
-- Created on: unknown
-- Last Modified by: Daniel Winograd-Cort
-- Last Modified on: 12/12/2013

-- This module requires the array and pure-fft packages.

{-# LANGUAGE Arrows #-}
module Euterpea.IO.MUI.FFT where
import FRP.UISF
import Control.Arrow.Operations
import Numeric.FFT (fft)
import Data.Complex
import Data.Map (Map)
import qualified Data.Map as Map

-- | Alternative for working with Math.FFT instead of Numeric.FFT
--import qualified Math.FFT as FFT
--import Data.Array.IArray
--import Data.Array.CArray
--myFFT n lst = elems $ (FFT.dft) (listArray (0, n-1) lst)

--------------------------------------
-- Fast Fourier Transform
--------------------------------------

-- | Returns n samples of type b from the input stream at a time,
--   updating after k samples.  This function is good for chunking
--   data and is a critical component to fftA
quantize :: ArrowCircuit a => Int -> Int -> a b (SEvent [b])
quantize n k = proc d -> do
    rec (ds,c) <- delay ([],0) -< (take n (d:ds), c+1)
    returnA -< if c >= n && c `mod` k == 0 then Just ds else Nothing

-- | Converts the vector result of a dft into a map from frequency to magnitude.
--   One common use is:
--      fftA >>> arr (fmap $ presentFFT clockRate)
presentFFT :: Double -> [Double] -> Map Double Double
presentFFT clockRate a = Map.fromList $ zipWith (curry mkAssoc) [0..] a where
    mkAssoc (i,c) = (freq, c) where
        samplesPerPeriod = fromIntegral (length a)
        freq = i * (clockRate / samplesPerPeriod)

-- | Given a quantization frequency (the number of samples between each
--   successive FFT calculation) and a fundamental period, this will decompose
--   the input signal into its constituent frequencies.
--   NOTE: The fundamental period must be a power of two!
fftA :: ArrowCircuit a => Int -> Int -> a Double (SEvent [Double])
fftA qf fp = proc d -> do
    carray <- quantize fp qf -< d :+ 0
    returnA -< fmap (map magnitude . take (fp `div` 2) . fft) carray

max_stars_repo_name: bsdr/Euterpea


text:
module Mllib.Metrics
    ( Metric
    , euclideanDistance
    , minkowskiDistance
    , chebyshevDistance
    , manhattanDistance
    ) where

import Mllib.Types

import Numeric.LinearAlgebra (cmap, sumElements, maxElement)

type Metric = (Vector R) -> (Vector R) -> R

euclideanDistance :: Metric
euclideanDistance v1 v2 = (sumElements (cmap (**2) (v1 - v2))) ** (1/2)

minkowskiDistance :: Int -> Metric
minkowskiDistance p v1 v2 = (sumElements (cmap (**pc) (v1 - v2))) ** (1 / pc)
  where
    pc = fromIntegral p

chebyshevDistance :: Metric
chebyshevDistance v1 v2 = maxElement $ cmap (abs) (v1 - v2)

manhattanDistance :: Metric
manhattanDistance v1 v2 = sumElements $ cmap (abs) (v1 - v2)

-- TODO test all above

-- TODO more metrics
-- -- Hamming
-- -- cos(x,z)
-- -- Canberra distance
-- -- ? Levenstein


text:
module Mnist where

import Data.List (nub, sort, intercalate)
import Codec.Compression.GZip (decompress)
import qualified Data.ByteString.Lazy as BS
import Numeric.LinearAlgebra (vector, Vector, R, Z, reshape, Matrix, toList, toRows, fromRows)

-- | typeclass that represents a dataset
class DataSet a where
  groupByLabel :: a -> [Matrix R]
  distinctLabels :: a -> [R]
  dataLabel :: a -> [(Vector R, R)]  -- pair the data and label for each sample
  -- oneHotLabel :: a -> Matrix Z

img_header_size = 16
label_header_size = 8
width = 28
img_size = 784

-- labeled data consists of data and their label
data LabeledData = LabeledData
    { dat :: !(Matrix R)  -- this has num_data >< data_dimension
    , label :: !(Vector R)
    }

-- define LabeledData as instance of DataSet typeclass
instance DataSet LabeledData where
    distinctLabels = sort . nub . toList . label
    groupByLabel ld = [
        -- extract index that matches the label, and cherrypicks them from data rows
        fromRows [dataRows !! idx | idx <- extractIdx lab]
        | lab <- distinctLabels ld ]
      where
        dataRows = toRows $ dat ld  -- represent matrix as list of rows
        labels = toList $ label ld  -- represent vector to list of values
        labelIdx = zip labels [0..]  -- zip it with index
        extractIdx targetLabel = map snd $ filter ((== targetLabel) . fst) labelIdx
    dataLabel ld = zip (toRows $ dat ld) (toList $ label ld)

-- mnist dataset consists of train set and a test set
data Mnist = Mnist
    { trainData :: LabeledData
    , testData :: LabeledData
    }

-- render a single number
render :: Vector R -> String
render s = intercalate "\n" $ splitted $ map (intensity . floor) (toList s)  -- insert \n every 28 chars
  where
    chars = " ..:oO0@"
    intensity n = chars !! (n * length chars `div` 256)
    splitted :: [a] -> [[a]]
    splitted [] = []
    splitted v = (take width v) : (splitted $ drop width v)  -- split by 28

-- convert byteString to vector -- in this case, bytestring is read as numbers byte by byte
byteStringToVector :: BS.ByteString -> Vector R
byteStringToVector = vector . map fromIntegral . BS.unpack

readDataFile :: String -> IO BS.ByteString
readDataFile filepath = decompress <$> BS.readFile filepath

-- make label data represented as Vector
makeLabelData :: BS.ByteString -> Vector R
makeLabelData = byteStringToVector . BS.drop 8  -- 8-byte header

-- make image data represented as Matrix
makeImgData :: BS.ByteString -> Matrix R
makeImgData = reshape img_size . byteStringToVector . BS.drop 16  -- 16-byte header

-- reads the file and creates a labeled data
readData :: String -> String -> IO LabeledData
readData imgfile labelfile = do
    imgData <- makeImgData <$> decompress <$> BS.readFile imgfile
    labelData <- makeLabelData <$> decompress <$> BS.readFile labelfile
    return $ LabeledData imgData labelData

readMnist :: IO Mnist
readMnist = do
    trainDataset <- readData "train-images-idx3-ubyte.gz" "train-labels-idx1-ubyte.gz"
    testDataset <- readData "t10k-images-idx3-ubyte.gz" "t10k-labels-idx1-ubyte.gz"
    return $ Mnist trainDataset testDataset

-- ByteString is an optimized representation of Word8.
-- BS.readFile :: FilePath -> IO ByteString
-- decompress :: ByteString -> ByteString
readMnistAndShow :: IO ()
readMnistAndShow = do
  imgData <- makeImgData <$> decompress <$> BS.readFile "train-images-idx3-ubyte.gz"
  labelData <- makeLabelData <$> decompress <$> BS.readFile "train-labels-idx1-ubyte.gz"
  putStrLn $ show $ labelData

max_stars_repo_name: deNsuh/hasml

max_issues_repo_name: deNsuh/hasml

max_forks_repo_name: deNsuh/hasml


text:
-- vectorized boolean operations defined in terms of step or cond

import Numeric.LinearAlgebra

infix  4  .==., ./=., .<., .<=., .>=., .>.
infixr 3  .&&.
infixr 2  .||.

a .<.  b = step (b-a)
a .<=. b = cond a b 1 1 0
a .==. b = cond a b 0 1 0
a ./=. b = cond a b 1 0 1
a .>=. b = cond a b 0 1 1
a .>.  b = step (a-b)

a .&&. b  = step (a*b)
a .||. b  = step (a+b)
no a      = 1-a
xor a b   = a ./=. b
equiv a b = a .==. b
imp a b   = no a .||. b

taut x = minElement x == 1

minEvery a b = cond a b a a b
maxEvery a b = cond a b b b a

-- examples

clip a b x = cond y b y y b where y = cond x a a x x

disp = putStr . dispf 3

eye n = ident n :: Matrix Double
row = asRow . fromList    :: [Double] -> Matrix Double
col = asColumn . fromList :: [Double] -> Matrix Double

m = (3><4) [1..] :: Matrix Double

p = row [0,0,1,1]
q = row [0,1,0,1]

main = do
    print $ find (>6) m
    disp $ assoc (6,8) 7 $ zip (find (/=0) (eye 5)) [10..]
    disp $ accum (eye 5) (+) [((0,2),3), ((3,1),7), ((1,1),1)]
    disp $ m .>=. 10  .||.  m .<. 4
    (disp . fromColumns . map flatten) [p, q, p.&&.q, p .||.q, p `xor` q, p `equiv` q, p `imp` q]
    print $ taut $ (p `imp` q ) `equiv` (no q `imp` no p)
    print $ taut $ (xor p q) `equiv` (p .&&. no q .||. no p .&&. q)
    disp $ clip 3 8 m
    disp $ col [1..7] .<=. row [1..5]
    disp $ cond (col [1..3]) (row [1..4]) m 50 (3*m)

max_stars_repo_name: curiousleo/liquidhaskell

max_issues_repo_name: curiousleo/liquidhaskell

max_forks_repo_name: curiousleo/liquidhaskell


text:
module Plotting where

import qualified Data.Random.Distribution.Normal        as DRDN
import qualified Data.Vector                            as V
import           Graphics.Rendering.Chart.Backend.Cairo
import           Graphics.Rendering.Chart.Easy
import qualified Numeric.LinearAlgebra.Data             as LAD
import qualified Sample                                 as S
import qualified Statistics.Distribution                as SD
import qualified Statistics.Distribution.Normal         as SDN
import qualified Statistics.Sample.Histogram            as SSH

normGrid :: [Double]
normGrid = LAD.toList $ LAD.linspace 100 (-3, 3)

normDensityGrid :: [Double]
normDensityGrid = fmap (SD.density SDN.standard) normGrid

fillFromZero :: [(Double, Double)] -> EC m2 (PlotFillBetween Double Double)
fillFromZero points = liftEC $ do
  plot_fillbetween_style .= solidFillStyle (grey `withOpacity` 0.25)
  plot_fillbetween_values .= fmap (\(x, y) -> (x, (0, y))) points

histPlot :: FilePath -> [(Double, Double)] -> IO ()
histPlot filename points = toFile def filename $ do
    setColors [opaque black]
    color <- takeColor
    plot (line "Density" [points])
    plot (fillFromZero points)

pHistPlot :: FilePath -> [Double] -> IO ()
pHistPlot = undefined

histogram :: Int -> [Double] -> [(Double, Double)]
histogram nBins xs = zip (V.toList grid) (V.toList densities)
  where
      (grid, counts) = SSH.histogram nBins (V.fromList xs)
      densities = V.map (\x -> x / fromIntegral (length xs)) counts

xs :: [Double]
xs = take 1000 (S.sample 123 DRDN.StdNormal)

go = histogram 25 xs

max_stars_repo_name: anthony-khong/ab-test-simulations

max_issues_repo_name: anthony-khong/ab-test-simulations

max_forks_repo_name: anthony-khong/ab-test-simulations


text:
import Debug.Trace
-- import Control.Monad.State.Lazy

import System.Environment (getArgs)
import System.IO (readFile)
import Data.Map.Strict (Map, (!), insert, elems, fromList, toList, findWithDefault, size, empty, member, findMin, findMax, singleton, filter)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
--import qualified Data.Array as A
import Data.List (permutations)
import Data.List.Split (splitOn)
import Data.Complex (Complex((:+)), realPart, imagPart)

import UI.NCurses

type Instructions = Map Integer Integer

data ComputerState = Ready | Running | Blocked | Done
  deriving (Show, Eq)

data Computer = Computer {
  state :: ComputerState,
  memory :: Map Integer Integer,
  iptr :: Integer, -- instruction pointer
  base :: Integer, -- base offset
  input :: [Integer],
  output :: [Integer]}

computer0 = Computer { state = Ready, memory = empty, iptr = 0, base = 0, input = [], output = [] }

run :: Computer -> Computer -- (Integer, Integer) -> Instructions -> [Integer] -> [Integer]
run c
  | state c == Ready = run $ c {state = Running}
  | state c == Done = c
  | state c == Blocked = if input c == [] then c else run $ c {state = Running}
  | otherwise = -- running
    --traceShow (iptr c, base c, memory c) $
    case instr `mod` 100 of
      1 -> -- add
        run $ c {iptr = i+4, memory = insert (addr 3) (arg 1 + arg 2) instructions}
      2 -> -- multiply
        run $ c {iptr = i+4, memory = insert (addr 3) (arg 1 * arg 2) instructions}
      3 -> -- read input
        if (null $ input c)
        then c {state = Blocked}
        else run $ c {iptr = i+2, memory = insert (addr 1) (head $ input c) instructions, input = tail $ input c}
      4 -> -- output
        --traceShow (arg 1) $
        run $ c {iptr = i+2, output = output c ++ [arg 1]}
      5 -> -- jump-if-true
        run $ c {iptr = if arg 1 == 0 then i+3 else arg 2}
      6 -> -- jump-if-false
        run $ c {iptr = if arg 1 == 0 then arg 2 else i+3}
      7 -> -- less than
        run $ c {iptr = i+4, memory = insert (addr 3) (if arg 1 < arg 2 then 1 else 0) instructions}
      8 -> -- equals
        run $ c {iptr = i+4, memory = insert (addr 3) (if arg 1 == arg 2 then 1 else 0) instructions}
      9 -> -- set relative base
        run $ c {iptr = i+2, base = base c + arg 1}
      99 -> -- halt
        run $ c {state = Done}
      _ -> error "unknown opcode"
  where instructions = memory c
        i = iptr c
        instr = instructions!i
        ii x = findWithDefault 0 x instructions
        arg :: Integer -> Integer
        arg n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ ii $ i+n
          1 -> ii $ i+n
          2 -> ii ((ii $ i+n) + base c)
          _ -> error "bad argument mode"
        addr n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ i+n
          1 -> error "address in mode 1"
          2 -> --trace "address in mode 2" $
            ii (i+n) + base c
          _ -> error $ "address in unknown mode"

instance Ord a => Ord (Complex a) where
  compare a b | ar < br || ar == br && ai < bi = LT
              | ar > br || ar == br && ai > bi = GT
              | otherwise = EQ
    where (ar, ai) = toParts a
          (br, bi) = toParts b

toParts :: Complex a -> (a, a)
toParts c = (realPart c, imagPart c)

toIntParts :: RealFrac a => Complex a -> (Int, Int)
toIntParts c = (round $ realPart c, round $ imagPart c)

fromParts :: (a, a) -> Complex a
fromParts (a,b) = a :+ b

data Game = Game
  { m :: Map (Integer, Integer) Integer -- map
  , x :: Integer
  , y :: Integer
  , minx :: Integer
  , miny :: Integer
  , maxx :: Integer
  , maxy :: Integer
  , explore :: [Int] -- stack of directions to explore
  } deriving (Show)

game0 = Game { m = empty, x = 0, y = 0, minx = 0, maxx = 0, miny = 0, maxy = 0, explore = [] }

updateGame :: Game -> Int -> Integer -> Game
updateGame g move status = updateMaxes $ case status of
  0 -> g { m = insert (x',y') 0 $ m g }
  1 -> g { m = insert (x',y') 1 $ m g, x = x', y = y'}
  2 -> g { m = insert (x',y') 2 $ m g, x = x', y = y'}
  where x' | move == 3 = x g - 1
           | move == 4 = x g + 1
           | otherwise = x g
        y' | move == 1 = y g + 1
           | move == 2 = y g - 1
           | otherwise = y g
        updateMaxes g = g
          { maxx = max x' $ maxx g
          , maxy = max y' $ maxy g
          , minx = min x' $ minx g
          , miny = min y' $ miny g
          }

topMargin = 5

drawGame :: Window -> Game -> Curses()
drawGame w g = do
  updateWindow w $ do
    clear
    (width, height) <- windowSize
    let (width', height') = (maxx g - minx g, maxy g - miny g)
    resizeWindow (max width width') (max height height')
    sequence_ [ draw i j val
              | i <- [minx g .. maxx g]
              , j <- [miny g .. maxy g]
              , let val = findWithDefault 5 (i,j) $ m g
              ]
  render
    where draw i j val = do
            let (y',x') =(maxy g - j + topMargin, i - minx g)
            if x' < 0 then error $ "x < 0: " ++ show x'
              else if y' < 0 then error $ "y < 0: " ++ show y'
                   else moveCursor y' x'
            if (i,j) == (x g, y g)
              then drawString "D"
              else drawString $ case val of
                                  5 -> " "
                                  0 -> "#"
                                  1 -> "."
                                  2 -> "*"
                                  _ -> error $  "unknown map value: " ++ show val

suggestMove :: Game -> Int
suggestMove g = search candidates seen
  where seen :: Set (Integer, Integer)
        seen = S.fromList [(x g, y g)]
        candidates :: Set (Int, Int, Integer, Integer) -- steps, direction, x, y
        candidates = S.fromList [ (1, 1, x g, y g + 1)
                                , (1, 2, x g, y g - 1)
                                , (1, 3, x g - 1, y g)
                                , (1, 4, x g + 1, y g)
                                ]
        search :: Set (Int, Int, Integer, Integer) -> Set (Integer, Integer) -> Int
        search candidates seen
          | S.null candidates = 5 -- error "explored all"
          | otherwise = let ((steps, direction, x', y'), candidates') = S.deleteFindMin candidates in
              if (x', y') `S.member` seen then search candidates' seen
              else
                let seen' :: Set (Integer, Integer)
                    seen' = S.insert (x',y') seen
                    candidates'' =
                      foldr S.insert candidates' [(steps+1, direction, x'+i, y'+j)| (i,j) <- [(-1,0),(0,-1),(1,0),(0,1)]]
                in case M.lookup (x',y') (m g) of
                     Nothing -> direction -- not explored at all
                     Just 0 -> search candidates' seen' -- wall
                     _ -> search candidates'' seen'

play :: Game -> Computer -> IO (Game)
play game c = runCurses $ do
  setEcho False
  w <- defaultWindow
  loop w game $ run c
    where loop :: Window -> Game -> Computer -> Curses(Game)
          loop w g c
            | state c == Done = do
                drawGame w g
                updateWindow w $ do
                  moveCursor 0 10
                  drawString "Press q to quit"
                render
                let qloop = do
                      ev <- getEvent w Nothing
                      case ev of
                        Nothing -> qloop
                        Just (EventCharacter 'q') -> return g
                        Just (EventCharacter 'Q') -> return g
                        _ -> qloop
                qloop
            | state c == Blocked = do -- waiting for input
                drawGame w g
                updateWindow w $ do
                  moveCursor 0 10
                  drawString "Move"
                render
                let moveLoop delay = do
                      moveEvent <- getEvent w  $ delay
                      case moveEvent of
                        Just (EventSpecialKey KeyUpArrow) -> return 1
                        Just (EventSpecialKey KeyDownArrow) -> return 2
                        Just (EventSpecialKey KeyLeftArrow) -> return 3
                        Just (EventSpecialKey KeyRightArrow) -> return 4
                        Nothing -> return $ suggestMove g
                        _ -> moveLoop delay
                move <- moveLoop $ Just 0
                if move == 5
                  then loop w g $ c{state = Done}
                  else let c' = run $ c {input = [fromIntegral move], output = []} in
                         loop w (updateGame g move $ head $ output c') $ c'{ input = [], output = [] }

            | otherwise = loop w game $ run c

type Point = (Integer,Integer)
type SearchState = (Int, Point)

main = do
  [instructionFile] <- getArgs
  instructionStrings <- readFile instructionFile
  let instructions = fromList . zip [0 ..] $ map read $ splitOn "," instructionStrings
  putStrLn "Part 1"
  game <- play game0 (computer0{memory = instructions})
  let search :: Set SearchState -> Set Point ->  SearchState
      search stateHeap seen
        | (m game)!(i,j) == 2 = (steps, (i,j)) -- found the goal, return the number of steps needed to reach it.
        | (m game)!(i,j) == 0 = search stateHeap' seen' -- testing a wall, don't add to the frontier
        | otherwise = search stateHeap'' seen' -- testing a clear spot, expand the frontier and keep searching
        where ((steps, (i,j)), stateHeap') = S.deleteFindMin stateHeap
              stateHeap'' = foldr S.insert stateHeap' $ frontier
              frontier = [(steps+1, pt)
                         | pt <- [(i+1,j), (i-1,j), (i,j+1), (i,j-1)]
                         , not $ pt `S.member` seen']
              seen' = S.insert (i,j) seen
  let (steps, oxygenOrigin) = search (S.singleton (0, (0,0))) S.empty
  putStrLn $ show $ (steps, oxygenOrigin)
  putStrLn "Part 2"
  let spread :: Set SearchState -> Set Point -> SearchState
      spread stateHeap seen
        | null stateHeap = (0, (0,0)) -- base case
        | otherwise = max (steps, (i,j)) $ spread stateHeap'' seen' -- testing a clear spot, expand the frontier and keep searching
        where ((steps, (i,j)), stateHeap') = -- traceShow stateHeap $
                S.deleteFindMin stateHeap
              stateHeap'' = foldr S.insert stateHeap' $ frontier
              frontier = [(steps+1, pt)
                         | pt <- [(i+1,j), (i-1,j), (i,j+1), (i,j-1)]
                         , not $ pt `S.member` seen'
                         , not $ (m game)!pt == 0 ]
              seen' = S.insert (i,j) seen
  let (steps, lastSpot) = spread (S.singleton (0, oxygenOrigin)) S.empty
  putStrLn $ show $ (steps, lastSpot)


text:
module AI.Learning.LogisticRegression where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Util

import AI.Learning.Core
import AI.Util.Matrix

-- |Multivariate logistic regression. Given a vector /y/ of target variables and
--  a design matrix /x/, this function fits the parameters /theta/ of a
--  logistic model, that is,
--
--  y = sigmoid( x_1 * theta_1 + ... + x_n * theta_n )
--
--  Typically the values in the vector /y/ are either boolean (i.e. 0/1) or they
--  represent frequency of observations, i.e. they are values between 0.0 and
--  1.0.
--
--  The function fits /theta/ by numerically maximizing the likelihood function.
--  It may be subject to overfit or non-convergence in the case where the number
--  of observations is small or the predictors are highly correlated.
lr :: Vector Double    -- targets (y)
   -> Matrix Double    -- design matrix (x)
   -> Vector Double    -- coefficient vector (theta)
lr y x = lrHelper (lrLogLikelihood y x) theta0
    where theta0  = constant 0 (cols x)

-- |Regularized logistic regression with quadratic penalty on the coefficients.
--  You should standardize the coefficients of the design matrix before using
--  this function, as the regularization procedure is sensitive to the scale
--  of the predictors. See also 'lr'.
lrRegularized :: Vector Double  -- targets (y)
              -> Matrix Double  -- design matrix (x)
              -> Bool           -- first column of design matrix is all ones?
              -> Double         -- regularization constant (lambda)
              -> Vector Double  -- coefficient vector (theta)
lrRegularized y x useConst lambda = lrHelper costfun theta0
    where
        costfun = lrLogLikRegularized y x useConst lambda
        theta0  = constant 0 (cols x)

-- |Helper function for logistic regressions. The first argument is a function
--  that returns the cost and gradient for a given vector of parameters, and
--  the second is the initial set of parameters to use.
lrHelper :: (Vector Double -> (Double, Vector Double)) -> Vector Double -> Vector Double
lrHelper fun theta0 = minimizeS cost grad theta0
    where cost    = negate . fst . fun -- negate because we call minimize
          grad    = negate . snd . fun

-- |Cost function and derivative for logistic regression. This is maximized when
--  fitting parameters for the regression.
lrLogLikelihood :: Vector Double             -- targets (y)
                -> Matrix Double             -- design matrix (x)
                -> Vector Double             -- coefficients (theta)
                -> (Double, Vector Double)   -- (value, derivative)
lrLogLikelihood y x theta = (cost, grad)
    where
        m    = fromIntegral (rows x)    -- For computing average
        h    = sigmoid (x <> theta)     -- Predictions for y
        cost = sumVector (y * log h + (1-y) * log (1-h)) / m
        grad = (1/m) `scale` (y - h) <> x

-- |Cost function and derivative for regularized logistic regression. This is
--  maximized when fitting parameters for the regression.
lrLogLikRegularized :: Vector Double            -- targets (y)
                    -> Matrix Double            -- design matrix (x)
                    -> Bool                     -- is first col all ones?
                    -> Double                   -- regularization const (lambda)
                    -> Vector Double            -- coefficients (theta)
                    -> (Double, Vector Double)  -- (value, derivative)
lrLogLikRegularized y x useConst lambda theta = (cost, grad)
    where
        m      = fromIntegral (rows x)
        (c,g)  = lrLogLikelihood y x theta
        theta' = if useConst then join [0, dropVector 1 theta] else theta
        cost   = c - (lambda / (2 * m)) * norm theta' ^ 2
        grad   = g - (lambda / m) `scale` theta'

-------------
-- Testing --
-------------

test n k lambda = do
    x <- randn n k                  -- design matrix
    e <- flatten `fmap` randn n 1   -- errors
    let theta = fromList $ 1 : replicate (k-1) 0
        h = sigmoid $ x <> theta + e
        y = (\i -> if i > 0.5 then 1 else 0) `mapVector` h
        theta_est1 = lr y x
        theta_est2 = lrRegularized y x False lambda
    --putStrLn $ "[y, h, x]"
    --disp 3 $ takeRows 10 $ fromColumns [y, h] ! x
    --putStrLn $ "[y, h, ypred]"
    --disp 3 $ takeRows 10 $ fromColumns [y, h, sigmoid $ x <> theta_est1]
    putStrLn $ "         Number of observations: " ++ show n
    putStrLn $ "           Number of regressors: " ++ show k
    putStrLn $ "                   Actual theta: " ++ show theta
    putStrLn $ "Estimated theta (unregularized): " ++ show theta_est1
    putStrLn $ "  Estimated theta (regularized): " ++ show theta_est2

max_stars_repo_name: cagix/aima-haskell


text:
{-# LANGUAGE FlexibleInstances #-}

import Debug.Trace
-- import Control.Monad.State.Lazy

import System.Environment (getArgs)
import System.IO (readFile)
import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
--import qualified Data.Array as A
import Data.List (find, intercalate, intersperse, permutations, inits, tails, isPrefixOf, isInfixOf, delete)
import Data.List.Split (splitOn)
-- import Data.Complex (Complex((:+)), realPart, imagPart) -- define my own complex

import Text.Regex.PCRE

import UI.NCurses
import Data.Char (chr, ord)
-- import Data.Complex (Complex((:+)))
import Data.Maybe (fromJust, isNothing, isJust)
type Instructions = Map Integer Integer

data ComputerState = Ready | Running | Blocked | Done
  deriving (Show, Eq)

data Computer = Computer {
  state :: ComputerState,
  memory :: Map Integer Integer,
  iptr :: Integer, -- instruction pointer
  base :: Integer, -- base offset
  input :: [Integer],
  output :: [Integer]}

toAscii ii = map (chr . fromIntegral) ii
fromAscii s = map (fromIntegral . ord) s

instance Show Computer where
  show c = "Computer < \""++toAscii (input c)++"\" > \""++toAscii (output c)++"\"\n"

computer0 = Computer { state = Ready, memory = M.empty, iptr = 0, base = 0, input = [], output = [] }

run :: Computer -> Computer -- (Integer, Integer) -> Instructions -> [Integer] -> [Integer]
run c
  | state c == Ready = -- traceShowId $
    run $ c {state = Running}
  | state c == Done = -- traceShowId $
    c
  | state c == Blocked = -- traceShowId $
    if input c == [] then c
    else run $ c {state = Running}
  | otherwise = -- running
    --traceShow (iptr c, base c, memory c) $
    case instr `mod` 100 of
      1 -> -- add
        run $ c {iptr = i+4, memory = M.insert (addr 3) (arg 1 + arg 2) instructions}
      2 -> -- multiply
        run $ c {iptr = i+4, memory = M.insert (addr 3) (arg 1 * arg 2) instructions}
      3 -> -- read input
        if (null $ input c)
        then c {state = Blocked}
        else run $ c {iptr = i+2, memory = M.insert (addr 1) (head $ input c) instructions, input = tail $ input c}
      4 -> -- output
        --traceShow (arg 1) $
        run $ c {iptr = i+2, output = output c ++ [arg 1]}
      5 -> -- jump-if-true
        run $ c {iptr = if arg 1 == 0 then i+3 else arg 2}
      6 -> -- jump-if-false
        run $ c {iptr = if arg 1 == 0 then arg 2 else i+3}
      7 -> -- less than
        run $ c {iptr = i+4, memory = M.insert (addr 3) (if arg 1 < arg 2 then 1 else 0) instructions}
      8 -> -- equals
        run $ c {iptr = i+4, memory = M.insert (addr 3) (if arg 1 == arg 2 then 1 else 0) instructions}
      9 -> -- set relative base
        run $ c {iptr = i+2, base = base c + arg 1}
      99 -> -- halt
        run $ c {state = Done}
      _ -> error "unknown opcode"
  where instructions = memory c
        i = iptr c
        instr = instructions!i
        ii x = M.findWithDefault 0 x instructions
        arg :: Integer -> Integer
        arg n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ ii $ i+n
          1 -> ii $ i+n
          2 -> ii ((ii $ i+n) + base c)
          _ -> error "bad argument mode"
        addr n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ i+n
          1 -> error "address in mode 1"
          2 -> --trace "address in mode 2" $
            ii (i+n) + base c
          _ -> error $ "address in unknown mode"

type Direction = String

-- data Direction = N | S | E | W
-- instance Show Direction where
--   show N = "north"
--   show S = "south"
--   show E = "east"
--   show W = "west"
-- instance Read Direction where
--   readsPrec _ ('n':'o':'r':'t':'h':theRest) = [(N, theRest)]
--   readsPrec _ ('s':'o':'u':'t':'h':theRest) = [(S, theRest)]
--   readsPrec _ ('e':'a':'s':'t':theRest) = [(E, theRest)]
--   readsPrec _ ('w':'e':'s':'t':theRest) = [(W, theRest)]

type Graph = Map String (Map Direction (Maybe String))

back "north" = "south"
back "south" = "north"
back "east" = "west"
back "west" = "east"
back d = error $ "unknown door type " ++ d

stripRoomName = reverse . drop 3 . reverse . drop 3 -- strip first 3 and last 3 characters
interactc :: Graph -> [(Direction, String)] -> Computer -> IO()
interactc g explorePath c = do
  let out = toAscii $ output c
      linesOut = lines out
      room = map stripRoomName $ filter (isPrefixOf "==") $ linesOut
      droidWeight
        | "Droids on this ship are heavier" `isInfixOf` out = "too light"
        | "Droids on this ship are lighter" `isInfixOf` out = "too heavy"
        | otherwise = "not applicable"
      -- if booted out, then last room listed is current room
      -- room = map (head . tail) $ (out =~ "== (.+?) ==" :: [[String]]) -- init $ tail $ head linesOut
      prompt = not $ null $ filter (== "Command?") linesOut
      stuff = map (drop 2) $ filter (isPrefixOf "- ") linesOut
      doors = filter (`elem` ["north","south","east","west"]) stuff
      items = filter (not . (`elem` ["infinite loop", "molten lava", "escape pod", "photons", "giant electromagnet"])) $ filter (not . (`elem` doors)) stuff
      newFrontier = not $ (null room || head room `M.member` g)
      (previousDoor, previousRoom) = head explorePath -- laziness ensures that explorePath is not null
      g' | newFrontier = M.insert (head room) (M.fromList [(door, Nothing)| door <- doors]) g
         | null room = g
         | null explorePath = trace "setting g': no explorePath" g
         | otherwise = M.adjust (\m -> M.insert (back $ previousDoor) (Just previousRoom) m) (head room) $
                       M.adjust (\m -> M.insert previousDoor (Just $ head room) m) previousRoom g
      (move, explorePath')
        | null room = ("to checkpoint", explorePath)
        | head room == "Security Checkpoint" = (back previousDoor, tail explorePath)
        | newFrontier = (head doors, (head doors, head room): explorePath)
        | null unexplored && null explorePath = ("inv", []) -- error "explored all"
        | null unexplored || head unexplored == previousRoom = (back previousDoor, tail explorePath)
        | otherwise = (head unexplored, (head unexplored, head room) : explorePath)
        where unexplored :: [Direction]
              unexplored = M.keys $ M.filter isNothing $ g!(head room)
  putStrLn out
  putStrLn $ "room: " ++ show room ++ "\nprompt: " ++ show prompt ++ "\ndoors: " ++ show doors ++ "\nitems: " ++ show items ++ "\nmove: " ++ show move ++ "\nexplorePath': " ++ show explorePath
  if not prompt then return ()
  else if move == "to checkpoint" then do
    putStrLn "Move to checkpoint"
    let pathToCheckpoint = traceShowId $ toCheckpoint g'
        c' = run $ c{output=[], input=concatMap ((\s -> s ++ [10]) . fromAscii) pathToCheckpoint}
    putStrLn $ toAscii $ output c'
    let c'' = run $ c'{output=[], input=fromAscii "inv\n"}
        items = map (drop 2) $ filter ("- " `isPrefixOf`) $ lines $ toAscii $ output c''
        c''' = run $ c''{output=[], input=concatMap fromAscii $ ["drop "++i++"\n" | i <- items]++["inv\n"]}
        testComputer = c'''{output=[]}
        testWeight items' | "heavier" `isInfixOf` out = True -- the items are ok, can add more
                          | "lighter" `isInfixOf` out = False -- too many items already
                          | otherwise = error $ "found it!\n" ++ out ++ show items'
          where out = toAscii $ output $ run $
                      testComputer{input=concatMap fromAscii $ ["take "++i++"\n"|i<-traceShowId $ S.toList items']++["east\n"]}
    putStrLn $ toAscii $ output c'''
    putStrLn "testing ..."
    print $ searchPowerSet 0 testWeight S.empty [(S.empty, items)]

    -- let c'' = passCheckpoint (head $ M.keys $ M.filter isNothing $ g!"Security Checkpoint") $
    --           c'{output = []}

    -- print $ g'
    -- s <- getLine
    -- interactc g' explorePath' $ run $ c{output=[], input=fromAscii s ++ [10]}

  else do
      if not (null items) then do
        putStrLn "Picking up items"
        let move' = "take " ++ head items
            c' = run $ c{output=[], input=fromAscii move' ++ [10]}
        putStrLn move'
        putStrLn $ toAscii $ output c'
        putStrLn move
        putStrLn $  "(explorePath = "++show explorePath++")"
        interactc g' explorePath' $ run $ c'{output=[], input=fromAscii move ++ [10]}
      else do
        putStrLn move
        putStrLn $  "(explorePath = "++show explorePath++")"
        interactc g' explorePath' $ run $ c{output=[], input=fromAscii move ++ [10]}

toCheckpoint g = search g "Security Checkpoint" $ [["Hull Breach"]]
  -- search the graph g depth-first, with the longest, current path at
  -- the head of the list of paths.
  where search g goal paths
          | null paths = error "null paths"
          | room == goal -- done, return path after removing rooms and reversing the order.
          = filter (`elem` ["north", "south", "east", "west"]) $ trace "path" $ traceShowId $ reverse path
          | null frontier -- if there is no frontier, ie, nothing
                          -- further to explore in the current path,
                          -- discard it and search the rest of the
                          -- paths.
          = search g goal $ tail paths
          | otherwise -- If there is a frontier, create new paths to
                      -- explore, add them to the front of the list,
                      -- and keep searching.
          = search g goal $ [room:door:path | (door, room) <- frontier] ++ tail paths
          where path = head paths
                room = head path
                frontier :: [(Direction, String)]
                -- the frontier is the doors leading to rooms from the
                -- current room, that also don't go back to rooms
                -- we've already explored in this path.
                frontier = M.toList $ M.filter (not . (`elem` path)) $ M.map fromJust $ M.filter isJust $ g!room

searchPowerSet:: Int -> (Set String -> Bool) -> Set (Set String) -> [(Set String, [String])] -> Set String
searchPowerSet i test tooBig ((yes,unknown): candidates)

  | (S.null $ S.filter (`S.isSubsetOf` yes) tooBig) && test yes
  = trace (show i++ ": keep going: "++show (S.toList yes)) $
    searchPowerSet (i+1) test tooBig $
    [(yes', unknown')
    | (u:unknown')<- init $ tails unknown
    , let yes' = S.insert u yes
    , S.null $ S.filter (`S.isSubsetOf` yes') tooBig
    ] ++candidates
  | otherwise
  = trace (show i++": skip this: "++show (S.toList yes)++"\nsets rejected: "++show (S.size tooBig + 1)) $
    searchPowerSet (i+1) test (S.insert yes tooBig) candidates

-- -- We're looking for a set of the right weight. Put the items in some
-- -- standard order and represent the set as a boolean list bs, whose
-- -- head is the last one included, i.e,
-- --      set = [i | (i, b) <- zip items $ reverse bs, b].
-- nextSet:: Int -> [Bool] -> ([Bool],[Bool]) -- (next smaller, next greater)
-- nextSet n bs
--   | n == length bs
--   = let bs' = True: False: drop 1 $ dropWhile (== False) $ dropWhile (== True) bs
--     in (bs', bs')
--   | otherwise
--   = ( True: False: drop 1 $ dropWhile (== False) $ drop 1 bs,
--       if length bs < n then True: bs else
--         True: False: drop 1 $ dropWhile (== False) $ dropWhile (== True) bs)
-- (error "True: bs,
-- hiloPowersetTester n = tester [Truen
--   where tester

-- ("Arcade",fromList [("north",Just "Navigation"),("west",Just "Kitchen")]),
-- ("Corridor",fromList [("north",Just "Holodeck"),("west",Just "Gift Wrapping Center")]),
-- ("Crew Quarters",fromList [("north",Just "Engineering")]),
-- ("Engineering",fromList [("east",Just "Hull Breach"),("south",Just "Crew Quarters"),("west",Just "Hallway")]),
-- ("Gift Wrapping Center",fromList [("east",Just "Corridor"),("north",Just "Observatory"),("south",Just "Hull Breach")]),
-- ("Hallway",fromList [("east",Just "Engineering"),("north",Just "Science Lab"),("south",Just "Sick Bay")]),
-- ("Holodeck",fromList [("south",Just "Corridor")]),
-- ("Hot Chocolate Fountain",fromList [("east",Just "Storage")]),
-- ("Hull Breach",fromList [("east",Just "Kitchen"),("north",Just "Gift Wrapping Center"),("west",Just "Engineering")]),
-- ("Kitchen",fromList [("east",Just "Arcade"),("west",Just "Hull Breach")]),
-- ("Navigation",fromList [("south",Just "Arcade"),("west",Just "Storage")]),
-- ("Observatory",fromList [("north",Just "Passages"),("south",Just "Gift Wrapping Center")]),
-- ("Passages",fromList [("south",Just "Observatory")]),
-- ("Science Lab",fromList [("east",Just "Security Checkpoint"),("south",Just "Hallway")]),
-- ("Security Checkpoint",fromList [("east",Nothing),("west",Just "Science Lab")]),
-- ("Sick Bay",fromList [("east",Just "Warp Drive Maintenance"),("north",Just "Hallway")]),
-- ("Stables",fromList [("south",Just "Warp Drive Maintenance")]),
-- ("Storage",fromList [("east",Just "Navigation"),("west",Just "Hot Chocolate Fountain")]),
-- ("Warp Drive Maintenance",fromList [("north",Just "Stables"),("west",Just "Sick Bay")])]

main = do
  print $ toAscii $ fromAscii "This is a test"
  -- [instructionFile] <- getArgs
  instructionStrings <- readFile "25.input.txt" -- instructionFile
  let instructions = M.fromList . zip [0 ..] $ map read $ splitOn "," instructionStrings

  putStrLn "Part 1"
  interactc M.empty [] $ run $ computer0{memory = instructions}
  -- let c = run $ computer0{memory = instructions}
  -- let view = output c
  -- let viewStr = map (chr . fromIntegral) view
  -- putStrLn $ viewStr


text:
module Runner where

import NeuralNet
import Mnist
import Backprop

import Numeric.LinearAlgebra
import Data.List
import Data.Maybe
import System.Random
import Debug.Trace

targets :: [[Double]]
targets =
    [
        [0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9]
    ]

{-
targets :: [[Double]]
targets =
    [
        [1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0]
    ]
-}

interpret :: [Double] -> Int
interpret v = fromJust (elemIndex (maximum v) v)

isMatch :: (Eq a) => a -> a -> Int
isMatch x y =
  if x == y
  then 1
  else 0

type LabelledImage = ([Double], Int)
-- ^ The training set, an array of input/target pairs

trainOnePattern
  :: (NeuralNet n)
  => LabelledImage
  -> n
  -> n
trainOnePattern trainingData net = train net input target
  where input = fst trainingData
        digit = snd trainingData
        target = targets !! digit

trainWithAllPatterns
  :: (NeuralNet n)
  => n
  -> [LabelledImage]
  -> n
trainWithAllPatterns = foldr trainOnePattern

evalOnePattern
  :: (NeuralNet n)
  => n
  -> LabelledImage
  -> Int
evalOnePattern net trainingData = isMatch result target
  where input = fst trainingData
        target = snd trainingData
        rawResult = evaluate net input
        result = interpret rawResult

evalAllPatterns
  :: (NeuralNet n)
  => n
  -> [LabelledImage]
  -> [Int]
evalAllPatterns = map . evalOnePattern

readTrainingData :: IO [LabelledImage]
readTrainingData = do
--  putStrLn "Reading training labels..."
  trainingLabels <- readLabels "train-labels-idx1-ubyte"
--  putStrLn $ "Read " ++ show (length trainingLabels) ++ " labels"
--  putStrLn "Reading training images..."
  trainingImages <- readImages "train-images-idx3-ubyte"
--  putStrLn $ "Read " ++ show (length trainingImages) ++ " images"
  return (zip (map normalisedData trainingImages) trainingLabels)

readTestData :: IO [LabelledImage]
readTestData = do
--  putStrLn "Reading test labels..."
  testLabels <- readLabels "t10k-labels-idx1-ubyte"
--  putStrLn $ "Read " ++ show (length testLabels) ++ " labels"
--  putStrLn "Reading test images..."
  testImages <- readImages "t10k-images-idx3-ubyte"
--  putStrLn $ "Read " ++ show (length testImages) ++ " images"
--  putStrLn "Testing..."
  return (zip (map normalisedData testImages) testLabels)

max_stars_repo_name: mhwombat/backprop-example

max_issues_repo_name: mhwombat/backprop-example

max_forks_repo_name: mhwombat/backprop-example


text:
module Markov where

import           MusicData
import           Utility

-- import           Numeric.LinearAlgebra (Matrix, R, (><))

import           Data.Map              (Map)
import qualified Data.Map              as Map (empty, insertWith, lookup)
import qualified Data.Map.Merge.Strict as Map' (merge, preserveMissing,
                                                zipWithMatched)
import qualified Data.Map.Strict       as Strict (Map)
import qualified Data.Map.Strict       as Map' (difference, elems, empty,
                                                fromList, insert, insertWith,
                                                keys, lookup, member, toList)
import qualified Data.Maybe            as Maybe (fromMaybe)
import qualified Data.Set              as Set (fromList, size, toList)

-- |representation of bigrams and containing deterministic cadence sequences
type Bigram  = (Cadence, Cadence)

-- |representation of counts for each trigram
type TransitionCounts = Strict.Map Bigram Double

-- -- |representations of the Markov transition matrix
-- type TransitionMatrix = Matrix R

-- |representation of markov transition matrix as key-value pairs
type MarkovMap = Map Cadence [(Cadence, Double)]

-- |mapping from list of events into list of existing preceding bigrams
bigrams :: [a] -> [(a, a)]
bigrams (x:xs)
  | length (x:xs) < 2 = []
  | otherwise = bigram (x:xs) : bigrams xs
  where bigram (x:y:ys) = (\a b -> (a, b)) x y

-- |lifted 'shortcut' `toCadence` which operates on a list of integer lists
toCadences    :: (Integral a, Num a) => [[a]] -> [Cadence]
toCadences xs = toCadence <$> bigrams (flatTriad <$> xs)

-- |mapping from input data into all theoretically possible bigrams
pairs   :: [Cadence] -> [Bigram]
pairs xs =
  let cs  = unique xs
   in [ (x, y) | x <- cs, y <- cs ]

-- |mapping from input data into all possible trigrams with counts of zero
zeroCounts             :: [Cadence] -> TransitionCounts
zeroCounts xs           =
  let mInsert acc key = Map'.insert key 0 acc
   in foldl mInsert Map'.empty $ pairs xs

-- |mapping from input data to counts of all occurring transitions
cadenceCounts        :: [Cadence] -> TransitionCounts
cadenceCounts xs      =
  let mInsert acc key = Map'.insertWith (+) key 1 acc
   in foldl mInsert Map'.empty $ bigrams xs

-- |mapping from input to counts of cadences, including 'stationary' movements
transitionCounts       :: [Cadence] -> TransitionCounts
transitionCounts xs     = mergeMaps (foldl mInsert cadences (Map'.keys diff)) zeros
  where diff            = Map'.difference zeros cadences
        zeros           = zeroCounts xs
        cadences        = cadenceCounts xs
        mergeMaps m1 m2 = Map'.merge Map'.preserveMissing Map'.preserveMissing
                          (Map'.zipWithMatched (\k x y -> x)) m1 m2
        keys k          = [ (fst k, nxt) | nxt <- unique xs ]
        newKey k        = (fst k, fst k)
        member k        = sequenceA [ f ks | f <- [Map'.member], ks <- keys k ] (cadences)
        mInsert acc key
          | all (\x -> x == False) (member key) == True =
              Map'.insert (newKey key) 1 acc
          | otherwise   =
              Map'.insert key (Maybe.fromMaybe 0 $ Map'.lookup key $ cadences) acc

-- |helper function for probabilityList which generates probability sublists
transitionProbs      :: [Cadence] -> [Double] -> [[Double]]
transitionProbs _ []  = []
transitionProbs xs ys =
  let j               = Set.size $ Set.fromList xs
      i               = j^2
      xx              = take j ys
      recurse         = drop j ys
   in fmap (/ sum xx) xx : transitionProbs xs recurse

-- |mapping from list of Cadences into list of transitions with probabilities
probabilityMap   :: [Cadence] -> Map Bigram Double
probabilityMap xs = Map'.fromList $ zip (Map'.keys $ zeroCounts xs) $ concat
                     . transitionProbs xs $ Map'.elems $ transitionCounts xs

-- -- |mapping from list of cadences into transition matrix
-- transitionMatrix   :: [Cadence] -> TransitionMatrix
-- transitionMatrix xs =
--   let n             = Set.size $ Set.fromList xs
--    in (n><n) $ Map'.elems $ probabilityMap xs :: Matrix R

-- |mapping from list of cadences into map with possible next probabilities
markovMap              :: [Cadence] -> MarkovMap
markovMap xs            = foldl mInsert Map.empty $ pairs xs
  where mInsert acc key = Map.insertWith (++) (fst key) (pList key) acc
        pList key       = [(snd key, Maybe.fromMaybe 0 $ Map.lookup key pMap)]
        pMap            = probabilityMap xs

max_stars_repo_name: OscarSouth/TheHarmonicAlgorithm

max_issues_repo_name: OscarSouth/TheHarmonicAlgorithm

max_forks_repo_name: OscarSouth/TheHarmonicAlgorithm


text:
module NeuralNet.Problem (
  Problem (),
  RunStep (),
  createProblem,
  runProblem,
  runStepIteration,
  runStepAccuracy,
  runStepCost,
  problemTestSet
) where

import NeuralNet.Example
import NeuralNet.Net
import NeuralNet.Layer
import NeuralNet.Cost
import NeuralNet.Train
import Numeric.LinearAlgebra

type NumIterations = Int
type LearningRate = Double
data Problem = Problem NeuralNetDefinition ExampleSet ExampleSet LearningRate NumIterations
  deriving (Show, Eq)

type IterationNum = Int
type Cost = Double
type Accuracy = Double
data RunStep = RunStep IterationNum Cost Accuracy
  deriving (Show, Eq)

runStepIteration :: RunStep -> IterationNum
runStepIteration (RunStep i _ _) = i

runStepCost :: RunStep -> Cost
runStepCost (RunStep _ c _) = c

runStepAccuracy :: RunStep -> Accuracy
runStepAccuracy (RunStep _ _ a) = a

problemNNDef :: Problem -> NeuralNetDefinition
problemNNDef (Problem d _ _ _ _) = d

problemTrainSet :: Problem -> ExampleSet
problemTrainSet (Problem _ t _ _ _) = t

problemTestSet :: Problem -> ExampleSet
problemTestSet (Problem _ _ t _ _) = t

problemLearningRate :: Problem -> LearningRate
problemLearningRate (Problem _ _ _ l _) = l

problemNumIterations :: Problem -> NumIterations
problemNumIterations (Problem _ _ _ _ i) = i

createProblem :: NeuralNetDefinition -> ExampleSet -> ExampleSet -> LearningRate -> NumIterations -> Problem
createProblem def trainSet testSet learningRate numIterations
  | not (isExampleSetCompatibleWithNNDef trainSet def) = error "trainSet not compatible with nn"
  | not (isExampleSetCompatibleWithNNDef testSet def)  = error "testSet not compatible with nn"
  | numIterations <= 0                                 = error "Must provide positive numIterations"
  | learningRate <= 0                                  = error "Must provide positive learningRate"
  | otherwise                                          = Problem def trainSet testSet learningRate numIterations

runProblem :: WeightsStream -> Problem -> (Double -> Double -> Bool) -> (NeuralNet, [RunStep], Double)
runProblem g p accuracyCheck = (resultNN, tail allSteps, testAccuracy)
  where
    startNN = initNN g (problemNNDef p)
    startStep = RunStep 0 1 0
    iterations = [1..(problemNumIterations p)]
    allNNAndSteps = reverse (foldl (\steps@((nn,_):_) i -> runProblemStep p i nn accuracyCheck : steps) [(startNN, startStep)] iterations)
    allSteps = map snd allNNAndSteps
    resultNN = fst (last allNNAndSteps)

    testSet = problemTestSet p
    testA = forwardPropA (last (nnForwardSet resultNN testSet))
    testAccuracy = calcAccuracy accuracyCheck testA (exampleSetY testSet)

runProblemStep :: Problem -> IterationNum -> NeuralNet -> (Double -> Double -> Bool) -> (NeuralNet, RunStep)
runProblemStep p i nn accuracyCheck = (newNN, RunStep i cost accuracy)
  where
    trainSet = problemTrainSet p
    forwardSteps = nnForwardSet nn trainSet
    al = forwardPropA (last forwardSteps)
    y = exampleSetY trainSet
    grads = nnBackward nn forwardSteps trainSet
    cost = computeCost al y
    newNN = updateNNParams nn grads (problemLearningRate p)
    accuracy = calcAccuracy accuracyCheck al y

calcAccuracy :: (Double -> Double -> Bool) -> Matrix Double -> Matrix Double -> Double
calcAccuracy accuracyCheck yHat y = fromIntegral numCorrect / fromIntegral (cols y)
  where
    numCorrect = length (filter (uncurry accuracyCheck) (zip (concat (toLists yHat)) (concat (toLists y))))
    -- TODO: Search for concat (toLists  - should be an easier way

max_stars_repo_name: danielholmes/neural-net

max_issues_repo_name: danielholmes/neural-net

max_forks_repo_name: danielholmes/neural-net


text:
{-# LANGUAGE RecordWildCards, FlexibleContexts #-}

import Control.Monad.Trans.Except
import Data.Complex
import Foreign.C.Types
import Data.Maybe
import Control.Monad

import Control.Error.Util
import Pipes as P
import qualified Pipes.Prelude as P
import Options.Applicative
import Data.Vector.Storable as VS hiding ((++))
import Data.Vector.Generic as VG hiding ((++))
import Graphics.Rendering.OpenGL

import Network.Socket (SockAddr(SockAddrInet), PortNumber, HostAddress)

import SDR.FFT
import SDR.Plot
import SDR.ArgUtils
import SDR.Util
import SDR.NetworkStream
import Graphics.DynamicGraph.Waterfall
import Graphics.DynamicGraph.Util

data Options = Options {
    fftSize      :: Maybe Int,
    windowWidth  :: Maybe Int,
    windowHeight :: Maybe Int,
    rows         :: Maybe Int,
    colorMap     :: Maybe [GLfloat],
    ip           :: Maybe HostAddress,
    port         :: Maybe PortNumber
}

parseColorMap :: ReadM [GLfloat]
parseColorMap = eitherReader func
    where
    func "jet"     = return jet
    func "jet_mod" = return jet_mod
    func "hot"     = return hot
    func "bw"      = return bw
    func "wb"      = return wb
    func arg       = Left $ "Cannot parse colour map: `" ++ arg ++ "'"

optParser :: Parser Options
optParser = Options
          <$> optional (option (fmap fromIntegral parseSize) (
                 long "size"
              <> short 's'
              <> metavar "SIZE"
              <> help "FFT bin size. Default is 512."
              ))
          <*> optional (option auto (
                 long "width"
              <> short 'w'
              <> metavar "WIDTH"
              <> help "Window width. Default is 1024."
              ))
          <*> optional (option auto (
                 long "height"
              <> short 'h'
              <> metavar "HEIGHT"
              <> help "Window height. Default is 480."
              ))
          <*> optional (option auto (
                 long "rows"
              <> short 'r'
              <> metavar "ROWS"
              <> help "Number of rows in waterfall. Default is 1000."
              ))
          <*> optional (option parseColorMap (
                 long "colorMap"
              <> short 'm'
              <> metavar "COLORMAP"
              <> help "Waterfall color map. Default is 'jet_mod'."
              ))
          <*> optional (option auto (
                 long "ip"
              <> short 'i'
              <> metavar "IP"
              <> help "IP address to bind to. Default is 0.0.0.0"
              ))
          <*> optional (option auto (
                 long "port"
              <> short 'p'
              <> metavar "PORT"
              <> help "UDP port to bind to. Default is 0x1234"
              ))

opt :: ParserInfo Options
opt = info (helper <*> optParser) (fullDesc <> progDesc "Draw a waterall plot of the samples received over Ethernet" <> header "Ethernet Waterfall")

{-# INLINE interleavedIQSigned256ToFloat #-}
interleavedIQSigned256ToFloat :: (Num a, Integral a, Num b, Fractional b, VG.Vector v1 a, VG.Vector v2 (Complex b)) => v1 a -> v2 (Complex b)
interleavedIQSigned256ToFloat input = VG.generate (VG.length input `quot` 2) convert
    where
    {-# INLINE convert #-}
    convert idx  = convert' (input `VG.unsafeIndex` (2 * idx)) :+ convert' (input `VG.unsafeIndex` (2 * idx + 1))
    {-# INLINE convert' #-}
    convert' val = fromIntegral val / 256

doIt Options{..} = do
    res <- lift setupGLFW
    unless res (throwE "Unable to initilize GLFW")

    let fftSize' =  fromMaybe 512 fftSize
        window   =  hanning fftSize' :: VS.Vector Double
    rfFFT        <- lift $ fftw fftSize'
    rfSpectrum   <- plotWaterfall (fromMaybe 1024 windowWidth) (fromMaybe 480 windowHeight) fftSize' (fromMaybe 1000 rows) (fromMaybe jet_mod colorMap)

    dev          <- lift $ udpRecvSocket $ SockAddrInet (fromMaybe 0x1234 port) (fromMaybe 0 ip)

    lift $ runEffect $   udpSource dev (fftSize' * 2)
                     >-> P.map (interleavedIQSigned256ToFloat :: VS.Vector CChar -> VS.Vector (Complex Double))
                     >-> P.map (VG.zipWith (flip mult) window . VG.zipWith mult (halfBandUp fftSize'))
                     >-> rfFFT
                     >-> P.map (VG.map ((* (32 / fromIntegral fftSize')) . realToFrac . magnitude))
                     >-> rfSpectrum

main = execParser opt >>= exceptT putStrLn return . doIt

max_stars_repo_name: adamwalker/sdr-apps

max_issues_repo_name: adamwalker/sdr-apps

max_forks_repo_name: adamwalker/sdr-apps


text:
module Proxy.PotentialFields.Internal.Fields where
import Proxy.Types.Game
import Proxy.Server.Messages
import Proxy.Query.Unit
import Data.Complex
import Data.List (foldl')
import Control.Applicative ((<*>))
import System.Random
import Control.DeepSeq
import Data.Array

--REALISTICALLY IT WOULD BE NICE TO GO IN AND CHANGE ALL OF THESE DEFINITIONS TO BE MUCH MORE ABSTRACT -IE REMOVE REFERENCES TO THE HSBWAPI

type PotCalc a = a -> UnitData -> Vector
type Vector = (Double,Double)

lOfTrap :: Int
lOfTrap = 5

sOfTrap :: Double
sOfTrap = 3

trapped :: [Location] -> [(Int,Location)]
trapped [] = []
trapped (x:xs) = if l > lOfTrap
                 then (l,centroid as) : trapped bs
                 else trapped bs
  where (as,bs) = span ((<3).(d x)) (x:xs)
        l = length as

passAvSize :: PotCalc (Int,Location)
passAvSize (i,l) u = mult (fromIntegral i) (passAv l u)

avoidTrappedOld :: PotCalc [Location]
avoidTrappedOld hs u =  foldr g nullVector (trapped hs)
  where g l v = passAvSize l u `add` v

avoidAllTrapped :: PotCalc [[Location]]
avoidAllTrapped lss u = vSum (map (flip avoidTrappedOld u) lss)

randMag :: Double
randMag = 0.5

nullVector :: Num a => (a,a)
nullVector = (0,0)

randomField :: RandomGen g => PotCalc g
randomField g _ = randMag `mult` (x,y)
  where x:y:_ = randomRs (-1,1) g

avoidAllOld :: PotCalc [Location]
avoidAllOld hs u = foldr g nullVector hs
  where g l v = passAv l u `add` v

nofield :: PotCalc a
nofield _ _ = nullVector

peaApp :: PotCalc Location
peaApp h fu = mult (-1) (grad h f)
 where f = unitLocation fu

agApp :: PotCalc UnitData
agApp hu fu = (2*di*(di - far)*(2*di - far)) `mult` grad h f
  where di = d h f
        h = unitLocation hu
        f = unitLocation fu
        far = fromIntegral $ if isFlyer.unitType $ hu
                             then airRange.unitType $ fu
                             else groundMaxRange.unitType $ fu

passAv :: PotCalc Location
passAv h fu = ((recip (d h f)) ^ 2) `mult` grad h f
  where f = unitLocation fu

passAvU :: PotCalc UnitData
passAvU = passAv.unitLocation

actAv :: PotCalc UnitData
actAv hu fu = (2*(di+har)*(di - hsr)*(di - har - hsr)) `mult` grad h f
  where di = d h f
        h = unitLocation hu
        f = unitLocation fu
        hsr = fromIntegral.(+1).sightRange.unitType $ hu
        har = fromIntegral.(+1) $ if isFlyer.unitType $ fu
                                  then airRange.unitType $ hu
                                  else groundMaxRange.unitType $ hu

mapData :: PotCalc [Location]
mapData xs = vSum . (([passAv] <*> xs) <*>) . (flip (:) [])

grad :: Location -> Location -> Vector
grad h@(hx,hy) f@(fx,fy) = (recip (d f h)) `mult` (fromIntegral $ fx-hx,fromIntegral $ fy-hy)

centroid :: [Location] -> Location
centroid xs = vmap round $ (recip . fromIntegral . length) xs `mult` (vmap fromIntegral . vSum) xs

mult :: (Num a) => a -> (a,a) -> (a,a)
mult x (v,w) = (x*v,x*w)

add :: (Num a) => (a,a) -> (a,a) -> (a,a)
add (x,y) (z,v) = (z+x,y+v)

vSum :: (Num a) => [(a,a)] -> (a,a)
vSum = foldl' add (0,0)

vmap :: (a -> b) -> (a,a) -> (b,b)
vmap f (x,y) = (f x, f y)

d ::(Floating a) => Location -> Location -> a
d (x,y) (z,w) = sqrt.fromIntegral $ ((x-z) ^ 2) + ((y-w) ^ 2)

{-
f :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> [[(a,c)]] -> [Array a b]
f g base bounds baselist xs = foldr h [] xs
  where arr y = accumArray g base bounds (baselist ++ y)
        h a b = arr a : b

test = f (\x y -> y) 0 (1,100000) (zip [1..100000] (repeat 1)) [[(100000,2)],[(1,1)],[],[],[(3,10)]]
-}


text:
module PNN where

import Data.Complex
import qualified Data.Vector as V
import Data.Matrix
import Data.Random.Normal
import Data.List (sortBy)
import Data.Number.BigFloat
import Math.NumberTheory.Zeta

type BF = BigFloat Prec50

n = 40 :: Int
k = 1 :: Int

s = 2.1 :: Double
sd = 1 / sqrt(s * (fromIntegral n))
seed = 1

makeComplex (x:y:xs) = (x :+ y) : makeComplex xs

mkBigNormals' :: (Double,Double) -> Int -> [BF]
mkBigNormals' (u,sd) seed = map (fromRational . toRational)
   (mkNormals' (u,sd) seed)

complexes = makeComplex (mkBigNormals' (0,sd) seed)

w_res = fromList (n-k) (n-k) complexes
w_in = fromList (n-k) k $ drop (nrows w_res * ncols w_res) complexes
x_res = V.fromList $ take (n-k) $ drop (nrows w_res * ncols w_res +
                                        nrows w_in * ncols w_in) complexes

-- function to predict
-- vector should have length k
epsilon = 1e-40 :: BF
zetas' = zetas epsilon
zs = [z :+ 0 | z <- zetas']
as c = V.singleton (zs !! (c+2))
{-
as c = let c' = 0.01 * (fromIntegral c) in
  V.fromList [sin c' + 0.1,
              cos (2*c'+1),
              3*(sin (c'+1)) - cos (3*c' + 2)]
-}

-- matrix / vector multiply
(*:) mat vec = getCol 1 (multStd mat (colVector vec))

-- vector addition
(=+=) va vb = V.zipWith (+) va vb

-- vector addition
(=-=) va vb = V.zipWith (-) va vb

fromVectors vs = fromLists (map V.toList vs)

mat_a = fromVectors (zipWith (V.++) (map as [0..])
                     (take n (map snd mat_a_gen)))

mat_a_gen = iterate f (0, x_res) where
  f (i, x_res') = (i+1, (w_in *: (as i)) =+= (w_res *: x_res'))

{-
-- not sure why this doesn't work
w_out =
  let m = mat_a <|> (fromVectors (map as [1..n]))
      Right m' = rref m
  in m' --submatrix 1 (n+1) (n+1) (n+k) m'
-}

solve m = backsub (triangular m)
 where
   sortRows = sortBy (\(r:_) (s:_) -> compare (realPart$abs s) (realPart$abs r))
   triangular = triangular' . sortRows

   downsub (u:us) (v:vs) = zipWith (-) (map ((v / u) *) us) vs

   triangular' [] = []
   triangular' rs | all (0 ==) (map head rs) = error "underdetermined"
   triangular' ((p:xs):rs) =
     let r = 1 : map (/ p) xs
         ss = map (downsub r) rs
     in r :  (triangular' ss)

   backsubOne (u:us) (1:vs) = zipWith (-) us (map (u *) vs)
   backsub' us [] = us
   backsub' us (v:vs) = backsub' ((tail v) : map (flip backsubOne v) us) vs
   backsub rs = reverse (backsub' [] rs)

{-
solve' m =
 let rows = length m
     a = map (take rows) m
     b = map (drop rows) m
 in L.transpose (O.many_kets_solution (L.transpose a) (L.transpose b))
-}

w_out = let m = mat_a <|> (fromVectors (map as [1..n]))
        in fromLists (solve (toLists m))

m = (transpose w_out) <-> (w_in <|> w_res)

guesses = map (V.take k) (iterate (m *:) ((as 0) V.++ x_res))

norm1 mat = maximum [V.sum (V.map (realPart . abs) (getCol c mat)) |
   c <- [1 .. ncols mat]]

number_of_guesses = 10
err = norm1 (fromVectors ((zipWith (=-=) (map as [0..]) (take (n+number_of_guesses) guesses))))

someFunc :: IO ()
someFunc = do
   let a = fromList 3 4 [1,6,2,8,9,3,9,0,1,5,2,7]
   let Right ra = rref a
   print (getDiag ra)
   print (getCol 4 ra)

max_stars_repo_name: rzil/honours

max_issues_repo_name: rzil/honours

max_forks_repo_name: rzil/honours


text:
{-# OPTIONS  #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Language.Scheme.R5RS.Parser.Token
-- Copyright   : (c) Tyler Prete
-- License     : BSD-style
-- Maintainer  : psyonic@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- Lexical tokens for the Scheme R5RS lexer.
-- See: <http://people.csail.mit.edu/jaffer/r5rs_9.html#SEC72>
-----------------------------------------------------------------------------

module Language.Scheme.R5RS.Parser.Token ( Token (..) )
where
import Language.Scheme.R5RS.Syntax.Expression (Number)
--import Data.Complex -- for Complex Float

-- | Lexical tokens.
data Token
    -- Identifier
    = Identifier !String
    | Boolean Bool
    | Number Number
    | Character Char
    | String !String
    | LeftParen
    | RightParen
    | PoundLeftParen
    | Tick
    | BackTick
    | Comma
    | CommaAt
    | Dot
    deriving (Eq, Show, Ord)

max_stars_repo_name: tylerprete/Haskell-Scheme-Compiler

max_issues_repo_name: tylerprete/Haskell-Scheme-Compiler

max_forks_repo_name: tylerprete/Haskell-Scheme-Compiler


text:
{-# language TemplateHaskell #-}

{-# options_ghc -O0 #-}

module Main (main) where

import Data.Complex (Complex(..))

import Data.Primitive.PrimArray (PrimArray)
import qualified Data.Primitive.PrimArray as PA

import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import Data.Primitive.Instances ()

import qualified Data.Primitive.Contiguous.FFT as CF
import qualified Numeric.MathFunctions.Comparison as MF

epsilon :: Double
epsilon = 0.0000000003

main :: IO Bool
main = checkParallel $$(discover)

prop_close :: Property
prop_close = property $ do
  x <- forAll genPrimArray
  let fft' = fft x
      {-# noinline fft' #-}
  let ifft' = ifft fft'
      {-# noinline ifft' #-}
  pwithin ifft' x === True

fft,ifft :: PrimArray (Complex Double) -> PrimArray (Complex Double)
fft = CF.fft
ifft = CF.ifft

pwithin :: PrimArray (Complex Double) -> PrimArray (Complex Double) -> Bool
pwithin xs ys = all (== True)
  $ zipWith within (PA.primArrayToList xs) (PA.primArrayToList ys)

within :: Complex Double -> Complex Double -> Bool
within (x :+ y) (x' :+ y') = abs (x - x') <= epsilon
  && abs (y - y') <= epsilon

genDouble :: Gen Double
genDouble = Gen.double (Range.linearFrac 5 200)

genComplex :: Gen (Complex Double)
genComplex = (:+) <$> genDouble <*> genDouble

genPrimArray :: Gen (PrimArray (Complex Double))
genPrimArray = PA.primArrayFromList <$> Gen.list (Range.singleton 8) genComplex

max_stars_repo_name: nprindle/contiguous-fft

max_issues_repo_name: nprindle/contiguous-fft

max_forks_repo_name: chessai/contiguous-fft


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Transform(
      --spectrum
      spectrum
    , testFFT
    , testFFT1
    , FFT(..)
    --, testBitReverse
    -- , bitReverse
    ) where

import Data.Complex
import qualified Numeric.GSL.Fourier as F
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed((!))
import qualified Data.Vector.Unboxed.Mutable as M
import Control.Monad.ST
import Data.Bits(shiftL,shiftR)
import Data.Int
import Data.Bits
import Control.Monad.Primitive
import Control.Monad(forM_,foldM_,when)
import Data.Word
import Data.Int
import Data.Bits
import Fixed
import Common(Time(..),Frequency(..))
import Windows
import Signal
import GHC.TypeLits
import Foreign.C.Types
import TypeAddition

--import Debug.Trace

isPowerOfTwo :: Word32 -> Bool
isPowerOfTwo a = (a /= 0) && ((a .&. (a-1)) == 0)

--debug a = trace (show a) a

restrictVectorToPOT :: U.Unbox a => U.Vector a -> (Int,U.Vector a)
restrictVectorToPOT v' | isPowerOfTwo (fromIntegral $ U.length v') = (n,v')
                       | otherwise = (n,U.generate (1 `shiftL` n) (v' !))
  where log2 x = log x / log 2
        n = floor (log2 (fromIntegral $ U.length v'))

_spectrum :: (FFT a, Sample a)
          => (Int -> Int -> a -> a)
          -> BSignal a
          -> U.Vector Double
_spectrum window d' =
    let vd' = toVectorBS d'
        (n,d) = restrictVectorToPOT vd'
        l = 1 `shiftL` n
        complexd = U.map (:+ 0) . U.imap (window l) $ d
        m (x :+ y) =
            let x' = toDouble x
                y' = toDouble y
            in
            (x'*x' + y'*y') / fromIntegral l
    in
    U.map m . fft  $ complexd

spectrum :: (FFT a, Sample a)
         => (Int -> Int -> a -> a)  -- ^ Window
         -> Int -- ^ Duration of signal
         -> Sampled Time a -- ^ Sampling period
         -> Sampled Frequency Double -- ^ (frequency resolution, Output spectrum)
spectrum window nbPoints signal =
    let f = (rate signal)
        s = _spectrum window . takeVectorS nbPoints $ (getSignal signal)
        nbSamples = U.length s
        freqResolution = f / fromIntegral nbSamples
        freqSignal = fromVectorS 0 s
    in
    Sampled freqResolution freqSignal

bitReverse :: Int -> Int -> Int
bitReverse bitSize a = fromIntegral $ br (bitSize - 1) 0 (fromIntegral a)
 where
  br :: Int -> Word64 -> Word64 -> Word64
  br i !r !a | i < 0 = r
             | a .&. 1 == 1 = br (i-1) (r .|. (1 `shiftL` i)) (a `shiftR` 1)
             | otherwise = br (i-1) (r) (a `shiftR` 1)

bitReverseA :: (M.Unbox a) => Int -> M.MVector s a -> ST s ()
bitReverseA nb m = do
    let l = 1 `shiftL` nb
    forM_ [0..l-1] $ \i -> do
      let j = fromIntegral $ bitReverse nb (fromIntegral i)
      when (j > i) $ M.swap m i j

--testBitReverse :: Int -> U.Vector Int
--testBitReverse n =
--    let v = U.fromList ([0..((1 `shiftL` n)-1)] :: [Int])
--        r = do
--               vect <- U.thaw v
--               bitReverseA n vect
--               U.freeze vect
--    in
--    runST r

instance Functor Complex where
    fmap f (a :+ b) = f a :+ f b

type FFTCore a = forall s . Int -> Int -> M.MVector s (Complex a) -> ST s ()

_fft :: Sample a
     => Int -- ^ Power of 2
     -> Int
     -> M.MVector s (Complex a)
     -> ST s ()
_fft n sign vect = do
    bitReverseA n vect
    let l = 1 `shiftL` n
    -- For all stages
    forM_ [0..n-1] $ \s -> do
        let step = 1 `shiftL` s -- Step for the stage
            w1 = fmap fromDouble . cis $ -pi*fromIntegral sign / fromIntegral step
            forAllBlocks w b = do
                forM_ (filter (<l) [b,(b + 2*step)..l]) $ \d -> do
                    let u = d + step
                    x <- M.read vect d
                    y <- M.read vect u
                    let x' = x + w * y
                        y' = x - w * y
                    M.write vect d x'
                    M.write vect u y'
                return (w*w1)
        -- Iterate butterflies. Compute butterfly nb for all blocks
        -- For instance : butterfly 1 for allb blocks
        -- Then butterfly 2 for all blocks
        foldM_ forAllBlocks (1 :+ 0) (filter (< step) [0,1..step])

mac ::  (SingI n, SingI r, SingI (15 + n))
    => Complex (Fixed Int16 15 Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int32 (15 + n) Sat r)
mac w y x = fmap convert x + amulc w y

msb ::  (SingI n, SingI r, SingI (15 + n))
    => Complex (Fixed Int16 15 Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int32 (15 + n) Sat r)
msb w y x = fmap convert x - amulc w y

_fftFixed :: (SingI n, SingI r, SingI (15 + n))
          => Int -- ^ Power of 2
          -> Int
          -> M.MVector s (Complex (Fixed Int16 n Sat r))
          -> ST s ()
_fftFixed n sign vect = do
    bitReverseA n vect
    let l = 1 `shiftL` n
    -- For all stages
    forM_ [0..n-1] $ \s -> do
        let step = 1 `shiftL` s -- Step for the stage
            w1 = fmap fromDouble . cis $ -pi*fromIntegral sign / fromIntegral step :: Complex (Fixed Int16 15 Sat r)
            forAllBlocks (w :: Complex (Fixed Int16 15 Sat r) ) b = do
                forM_ (filter (<l) [b,(b + 2*step)..l]) $ \d -> do
                    let u = d + step
                    x <- M.read vect d
                    y <- M.read vect u
                    let x' = mac w y x
                        y' = msb w y x
                    M.write vect d (fmap convert x')
                    M.write vect u (fmap convert y')
                return (w*w1)
        -- Iterate butterflies. Compute butterfly nb for all blocks
        -- For instance : butterfly 1 for allb blocks
        -- Then butterfly 2 for all blocks
        foldM_ forAllBlocks (1 :+ 0) (filter (< step) [0,1..step])

genericfft :: Sample a
           => Bool
           -> FFTCore a
           -> U.Vector (Complex a)
           -> U.Vector (Complex a)
genericfft inverse fftCore v' =
    let (n,v) = restrictVectorToPOT v'
        sign | inverse = -1
             | otherwise = 1
        r = do
              vect <- U.thaw v
              fftCore n sign vect
              when inverse $ do
                let l = 1 `shiftL` n
                    scale = (fromDouble $ (1.0 / fromIntegral l)) :+ 0
                forM_ [0..l-1] $ \i -> do
                    x <- M.read vect i
                    M.write vect i (x*scale)
              U.freeze vect
    in
    runST r

class FFT a where
    fft :: Sample a
        => U.Vector (Complex a)
        -> U.Vector (Complex a)
    fft = genericfft False _fft

    ifft :: Sample a
         => U.Vector (Complex a)
         -> U.Vector (Complex a)
    ifft = genericfft True _fft

instance FFT Double

instance (SingI n, SingI r, SingI (15 + n)) => FFT (Fixed Int16 n Sat r) where
    fft = genericfft False _fftFixed
    ifft = genericfft True _fftFixed

testFFT :: (FFT a,Sample a) => Int -> Signal a -> U.Vector (Complex Double)
testFFT n s = U.map (fmap toDouble) . fft . toVectorBS . mapBS (:+ 0) . takeVectorS n $ s

testFFT1 :: Sample a => Int -> Signal a -> U.Vector (Complex Double)
testFFT1 n s = U.convert . F.fft . U.convert . toVectorBS . mapBS ((:+ 0) . toDouble) . takeVectorS n $ s

max_stars_repo_name: alpheccar/Signal

max_issues_repo_name: cpehle/Signal

max_forks_repo_name: cpehle/Signal


text:
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedLists      #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Pretty printing for Generic data types

module Text.PrettyPrint.Generic (
  -- * Type classes
  Pretty(..),
  GPretty(..),

  -- * Utility functions
  pretty,  prettyShow,  prettyPrint,  hPrettyPrint,
  pretty', prettyShow', prettyPrint', hPrettyPrint',
  ) where

import           GHC.Exts                     (IsList (..))
import           GHC.Generics
import           System.IO
import           Text.PrettyPrint.ANSI.Leijen hiding (Pretty (..))

import           Control.Applicative          (Const, WrappedArrow,
                                               WrappedMonad, ZipList)
import qualified Data.ByteString.Char8        as S
import qualified Data.ByteString.Lazy.Char8   as L
import           Data.Complex
import           Data.Functor.Identity        (Identity)
import           Data.Int
import qualified Data.IntMap                  as IntMap
import qualified Data.IntSet                  as IntSet
import qualified Data.Map                     as Map
import           Data.Monoid                  (All, Alt, Any, First, Last,
                                               Product, Sum)
import           Data.Ratio
import qualified Data.Sequence                as Seq
import qualified Data.Set                     as Set
import qualified Data.Text                    as T
import qualified Data.Text.Encoding           as T
import qualified Data.Text.Lazy               as TL
import qualified Data.Vector                  as V
import qualified Data.Vector.Primitive        as VP
import qualified Data.Vector.Storable         as VS
import qualified Data.Vector.Unboxed          as VU
import           Data.Word

-- Color scheme

constructorS, numericS, stringS, operatorS, selectorS :: Doc -> Doc
constructorS = underline . bold . dullgreen
numericS     = magenta
stringS      = dullyellow
operatorS    = dullred
selectorS    = blue

-- Generic function

-- | Type class for generic representations
class GPretty f where
  -- | Pretty print a `Generic` value
  gprettyPrec :: Int -> f a -> [Doc]

instance GPretty V1 where
  gprettyPrec _ _ = error "this never happen"

instance GPretty U1 where
  gprettyPrec _ U1 = []

instance Pretty c => GPretty (Rec0 c) where
  gprettyPrec p (K1 c) = [prettyPrec p c]

instance GPretty f => GPretty (D1 d f) where
  gprettyPrec p (M1 a) = gprettyPrec p a

instance (GPretty f, Constructor c) => GPretty (C1 c f) where
  gprettyPrec p c@(M1 a)
    | conIsRecord c =
      [ con <+> encloseSep (lbrace <> space) (space <> rbrace) (comma <> space) es ]
    | null es      = [ con ]
    | p == 0       = [ con <+> align (sep es) ]
    | otherwise    = [ parens $ con <+> align (sep es) ]
    where
      con = constructorS $ text (conName c)
      es = gprettyPrec (p + 1) a

instance {-# OVERLAPPABLE #-} (GPretty f, Selector s) => GPretty (S1 s f) where
  gprettyPrec _ s@(M1 a) =
    [ selectorS (text (selName s)) <+> operatorS (text "=") <+> sep (gprettyPrec 0 a) ]
instance {-# OVERLAPPING #-} GPretty f => GPretty (S1 ('MetaSel 'Nothing su ss ds) f) where
  gprettyPrec p (M1 a) = gprettyPrec p a

instance (GPretty f, GPretty g) => GPretty (f :+: g) where
  gprettyPrec p (L1 a) = gprettyPrec p a
  gprettyPrec p (R1 a) = gprettyPrec p a

instance (GPretty f, GPretty g) => GPretty (f :*: g) where
  gprettyPrec p (a :*: b) = gprettyPrec p a ++ gprettyPrec p b

-- Wrapper function

-- | Type class for pretty printing
class Pretty a where
  -- | Pretty print a value to `Doc`
  prettyPrec :: Int -> a -> Doc
  default prettyPrec :: (Generic a, GPretty (Rep a)) => Int -> a -> Doc
  prettyPrec p = sep . gprettyPrec p . from

-- Utility functions

-- | Pretty print a value with decoration
pretty :: Pretty a => a -> Doc
pretty = prettyPrec 0

-- | Pretty print a value to `String`
prettyShow :: Pretty a => a -> String
prettyShow = show . pretty

-- | Pretty print a value to `stdout`
prettyPrint :: Pretty a => a -> IO ()
prettyPrint = hPrettyPrint stdout

-- | Pretty print a value
hPrettyPrint :: Pretty a => Handle -> a -> IO ()
hPrettyPrint h = hPutDoc h . (<> hardline) . pretty

-- | Pretty print a value without decoration
pretty' :: Pretty a => a -> Doc
pretty' = plain . pretty

-- | Plain version for `prettyShow`
prettyShow' :: Pretty a => a -> String
prettyShow' = show . pretty'

-- | Plain version for `prettyPrint`
prettyPrint' :: Pretty a => a -> IO ()
prettyPrint' = hPrettyPrint' stdout

-- | Plain version for `hPrettyPrint`
hPrettyPrint' :: Pretty a => Handle -> a -> IO ()
hPrettyPrint' h = hPutDoc h . (<> hardline) . pretty'

-- instances

instance Pretty ()      where prettyPrec _ = text . show
instance Pretty Char    where prettyPrec _ = stringS . text . show
instance Pretty Int     where prettyPrec _ = numericS . text . show
instance Pretty Integer where prettyPrec _ = numericS . text . show
instance Pretty Float   where prettyPrec _ = numericS . text . show
instance Pretty Double  where prettyPrec _ = numericS . text . show
instance Pretty Bool    where prettyPrec _ = numericS . text . show

instance Pretty Word    where prettyPrec _ = numericS . text . show
instance Pretty Word8   where prettyPrec _ = numericS . text . show
instance Pretty Word16  where prettyPrec _ = numericS . text . show
instance Pretty Word32  where prettyPrec _ = numericS . text . show
instance Pretty Word64  where prettyPrec _ = numericS . text . show

instance Pretty Int8    where prettyPrec _ = numericS . text . show
instance Pretty Int16   where prettyPrec _ = numericS . text . show
instance Pretty Int32   where prettyPrec _ = numericS . text . show
instance Pretty Int64   where prettyPrec _ = numericS . text . show

instance (Integral a, Pretty a) => Pretty (Ratio a) where
  prettyPrec _ r =
    pretty (numerator r) <+> operatorS (char '%') <+> pretty (denominator r)

instance (Pretty a) => Pretty (Complex a) where
  prettyPrec _ (r :+ i) =
    pretty r <+> operatorS (text ":+") <+> pretty i

instance {-# OVERLAPPABLE #-} Pretty a => Pretty [a] where
  prettyPrec _ = encloseSep (lbracket <> space) (space <> rbracket) (comma <> space) . map pretty

instance {-# OVERLAPPING #-} Pretty String where
  prettyPrec _ = stringS . dquotes . text . prettyString where
    prettyString cs = foldr ((.) . prettyChar) id cs ""
    prettyChar c
      | fromEnum c < 0x80 = showChar c
      | otherwise = (c:)

instance (Pretty a, Pretty b) => Pretty (a, b) where
  prettyPrec _ (a, b) = parens $ pretty a <> comma <+> pretty b

instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where
  prettyPrec _ (a, b, c) = parens $ pretty a <> comma <+> pretty b <> comma <+> pretty c

instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where
  prettyPrec _ (a, b, c, d) = parens $ pretty a <> comma <+> pretty b <> comma <+> pretty c <> comma <+> pretty d

instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where
  prettyPrec _ (a, b, c, d, e) = parens $ pretty a <> comma <+> pretty b <> comma <+> pretty c <> comma <+> pretty d <> comma <+> pretty e

instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where
  prettyPrec _ (a, b, c, d, e, f) = parens $ pretty a <> comma <+> pretty b <> comma <+> pretty c <> comma <+> pretty d <> comma <+> pretty e <> comma <+> pretty f

instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => Pretty (a, b, c, d, e, f, g) where
  prettyPrec _ (a, b, c, d, e, f, g) = parens $ pretty a <> comma <+> pretty b <> comma <+> pretty c <> comma <+> pretty d <> comma <+> pretty e <> comma <+> pretty f <> comma <+> pretty g

instance Pretty a => Pretty (Maybe a)
instance (Pretty a, Pretty b) => Pretty (Either a b)
instance Pretty Ordering
instance Pretty Any
instance Pretty All
instance Pretty a => Pretty (First a)
instance Pretty a => Pretty (Last a)
instance Pretty a => Pretty (Sum a)
instance Pretty a => Pretty (Product a)
instance Pretty (f a) => Pretty (Alt f a)
instance Pretty a => Pretty (Identity a)
instance Pretty a => Pretty (Const a b)
instance Pretty a => Pretty (ZipList a)
instance Pretty (m a) => Pretty (WrappedMonad m a)
instance Pretty (a b c) => Pretty (WrappedArrow a b c)

-- bytestrings, texts

instance Pretty S.ByteString where
  prettyPrec _ bs = case T.decodeUtf8' bs of
    Left err -> pretty $ show err
    Right t -> pretty t

instance Pretty T.Text where
  prettyPrec _ = pretty . T.unpack

instance Pretty L.ByteString where
  prettyPrec _ = pretty . L.toStrict

instance Pretty TL.Text where
  prettyPrec _ = pretty . TL.toStrict

-- containers

instance (Pretty a, Ord a) => Pretty (Set.Set a) where
  prettyPrec _ = encloseSep (lbracket <> space) (space <> rbracket) (comma <> space) . map pretty . toList

instance Pretty IntSet.IntSet where
  prettyPrec _ = pretty . Set.fromList . toList

instance (Pretty a, Pretty b, Ord a) => Pretty (Map.Map a b) where
  prettyPrec _ = encloseSep (lbrace <> space) (space <> rbrace) (comma <> space) . map f . toList where
    f (key, val) = pretty key <> colon <+> pretty val

instance Pretty b => Pretty (IntMap.IntMap b) where
  prettyPrec _ = pretty . Map.fromList . toList

instance Pretty a => Pretty (Seq.Seq a) where
  prettyPrec _ = pretty . toList

-- vectors

instance Pretty a => Pretty (V.Vector a) where
  prettyPrec _ = pretty . toList

instance (Pretty a, VP.Prim a) => Pretty (VP.Vector a) where
  prettyPrec _ = pretty . toList

instance (Pretty a, VS.Storable a) => Pretty (VS.Vector a) where
  prettyPrec _ = pretty . toList

instance (Pretty a, VU.Unbox a) => Pretty (VU.Vector a) where
  prettyPrec _ = pretty . toList

max_stars_repo_name: neilmayhew/generic-pretty

max_issues_repo_name: neilmayhew/generic-pretty

max_forks_repo_name: neilmayhew/generic-pretty


text:
module StatReport (statReport, showStatEntryValue) where

import Fmt
import Data.Text (Text)
import Data.Fixed (showFixed)
import QuoteData (QField(..))
import Statistics (Statistic(..), StatEntry(..), StatQFieldData, StatInfo)

instance Buildable Statistic where
  build Mean = "Mean"
  build Min = "Minimum"
  build Max = "Maximum"
  build Days = "Days between Min/Max"

showStatEntryValue :: StatEntry -> String
showStatEntryValue StatEntry {..} = showFixed (removeTrailings stat qfield) value where
  removeTrailings Days _ = True
  removeTrailings Min Volume = True
  removeTrailings Max Volume = True
  removeTrailings _ _ = False

instance Buildable StatEntry where
  build se@StatEntry {..} = "" +|stat|+ ": " +|showStatEntryValue se|+ ""

instance Buildable StatQFieldData where
  build (qf, stats) = nameF ("Statistic for " +||qf||+ "") $ unlinesF stats

statReport :: StatInfo -> Text
statReport = fmt . unlinesF