Color Optimized

Color Optimized

module RNX.Color where

import Prelude

import Data.Int (hexadecimal, toStringAs)

newtype Color = Color String

rgb :: Int -> Int -> Int -> Color
rgb r g b = Color $ "rgb(" <> show r <> ", " <> show g <> ", " <> show b <> ")"

rgba :: Int -> Int -> Int -> Number -> Color
rgba r g b a = Color $ "rgba(" <> show r <> ", " <> show g <> ", " <> show b <> ", " <> show a <> ")"

rgbi :: Int -> Color
rgbi i = Color $ "#" <> toStringAs hexadecimal i

transparent :: Color
transparent = Color "transparent"

aliceblue :: Color
aliceblue = Color "aliceblue"

antiquewhite :: Color
antiquewhite = Color "antiquewhite"

aqua :: Color
aqua = Color "aqua"

aquamarine :: Color
aquamarine = Color "aquamarine"

azure :: Color
azure = Color "azure"

beige :: Color
beige = Color "beige"

bisque :: Color
bisque = Color "bisque"

black :: Color
black = Color "black"

blanchedalmond :: Color
blanchedalmond = Color "blanchedalmond"

blue :: Color
blue = Color "blue"

blueviolet :: Color
blueviolet = Color "blueviolet"

brown :: Color
brown = Color "brown"

burlywood :: Color
burlywood = Color "burlywood"

cadetblue :: Color
cadetblue = Color "cadetblue"

chartreuse :: Color
chartreuse = Color "chartreuse"

chocolate :: Color
chocolate = Color "chocolate"

coral :: Color
coral = Color "coral"

cornflowerblue :: Color
cornflowerblue = Color "cornflowerblue"

cornsilk :: Color
cornsilk = Color "cornsilk"

crimson :: Color
crimson = Color "crimson"

cyan :: Color
cyan = Color "cyan"

darkblue :: Color
darkblue = Color "darkblue"

darkcyan :: Color
darkcyan = Color "darkcyan"

darkgoldenrod :: Color
darkgoldenrod = Color "darkgoldenrod"

darkgray :: Color
darkgray = Color "darkgray"

darkgreen :: Color
darkgreen = Color "darkgreen"

darkgrey :: Color
darkgrey = Color "darkgrey"

darkkhaki :: Color
darkkhaki = Color "darkkhaki"

darkmagenta :: Color
darkmagenta = Color "darkmagenta"

darkolivegreen :: Color
darkolivegreen = Color "darkolivegreen"

darkorange :: Color
darkorange = Color "darkorange"

darkorchid :: Color
darkorchid = Color "darkorchid"

darkred :: Color
darkred = Color "darkred"

darksalmon :: Color
darksalmon = Color "darksalmon"

darkseagreen :: Color
darkseagreen = Color "darkseagreen"

darkslateblue :: Color
darkslateblue = Color "darkslateblue"

darkslategray :: Color
darkslategray = Color "darkslategray"

darkslategrey :: Color
darkslategrey = Color "darkslategrey"

darkturquoise :: Color
darkturquoise = Color "darkturquoise"

darkviolet :: Color
darkviolet = Color "darkviolet"

deeppink :: Color
deeppink = Color "deeppink"

deepskyblue :: Color
deepskyblue = Color "deepskyblue"

dimgray :: Color
dimgray = Color "dimgray"

dimgrey :: Color
dimgrey = Color "dimgrey"

dodgerblue :: Color
dodgerblue = Color "dodgerblue"

firebrick :: Color
firebrick = Color "firebrick"

floralwhite :: Color
floralwhite = Color "floralwhite"

forestgreen :: Color
forestgreen = Color "forestgreen"

fuchsia :: Color
fuchsia = Color "fuchsia"

gainsboro :: Color
gainsboro = Color "gainsboro"

ghostwhite :: Color
ghostwhite = Color "ghostwhite"

gold :: Color
gold = Color "gold"

goldenrod :: Color
goldenrod = Color "goldenrod"

gray :: Color
gray = Color "gray"

green :: Color
green = Color "green"

greenyellow :: Color
greenyellow = Color "greenyellow"

grey :: Color
grey = Color "grey"

honeydew :: Color
honeydew = Color "honeydew"

hotpink :: Color
hotpink = Color "hotpink"

indianred :: Color
indianred = Color "indianred"

indigo :: Color
indigo = Color "indigo"

ivory :: Color
ivory = Color "ivory"

khaki :: Color
khaki = Color "khaki"

lavender :: Color
lavender = Color "lavender"

lavenderblush :: Color
lavenderblush = Color "lavenderblush"

lawngreen :: Color
lawngreen = Color "lawngreen"

lemonchiffon :: Color
lemonchiffon = Color "lemonchiffon"

lightblue :: Color
lightblue = Color "lightblue"

lightcoral :: Color
lightcoral = Color "lightcoral"

lightcyan :: Color
lightcyan = Color "lightcyan"

lightgoldenrodyellow :: Color
lightgoldenrodyellow = Color "lightgoldenrodyellow"

lightgray :: Color
lightgray = Color "lightgray"

lightgreen :: Color
lightgreen = Color "lightgreen"

lightgrey :: Color
lightgrey = Color "lightgrey"

lightpink :: Color
lightpink = Color "lightpink"

lightsalmon :: Color
lightsalmon = Color "lightsalmon"

lightseagreen :: Color
lightseagreen = Color "lightseagreen"

lightskyblue :: Color
lightskyblue = Color "lightskyblue"

lightslategray :: Color
lightslategray = Color "lightslategray"

lightslategrey :: Color
lightslategrey = Color "lightslategrey"

lightsteelblue :: Color
lightsteelblue = Color "lightsteelblue"

lightyellow :: Color
lightyellow = Color "lightyellow"

lime :: Color
lime = Color "lime"

limegreen :: Color
limegreen = Color "limegreen"

linen :: Color
linen = Color "linen"

magenta :: Color
magenta = Color "magenta"

maroon :: Color
maroon = Color "maroon"

mediumaquamarine :: Color
mediumaquamarine = Color "mediumaquamarine"

mediumblue :: Color
mediumblue = Color "mediumblue"

mediumorchid :: Color
mediumorchid = Color "mediumorchid"

mediumpurple :: Color
mediumpurple = Color "mediumpurple"

mediumseagreen :: Color
mediumseagreen = Color "mediumseagreen"

mediumslateblue :: Color
mediumslateblue = Color "mediumslateblue"

mediumspringgreen :: Color
mediumspringgreen = Color "mediumspringgreen"

mediumturquoise :: Color
mediumturquoise = Color "mediumturquoise"

mediumvioletred :: Color
mediumvioletred = Color "mediumvioletred"

midnightblue :: Color
midnightblue = Color "midnightblue"

mintcream :: Color
mintcream = Color "mintcream"

mistyrose :: Color
mistyrose = Color "mistyrose"

moccasin :: Color
moccasin = Color "moccasin"

navajowhite :: Color
navajowhite = Color "navajowhite"

navy :: Color
navy = Color "navy"

oldlace :: Color
oldlace = Color "oldlace"

olive :: Color
olive = Color "olive"

olivedrab :: Color
olivedrab = Color "olivedrab"

orange :: Color
orange = Color "orange"

orangered :: Color
orangered = Color "orangered"

orchid :: Color
orchid = Color "orchid"

palegoldenrod :: Color
palegoldenrod = Color "palegoldenrod"

palegreen :: Color
palegreen = Color "palegreen"

paleturquoise :: Color
paleturquoise = Color "paleturquoise"

palevioletred :: Color
palevioletred = Color "palevioletred"

papayawhip :: Color
papayawhip = Color "papayawhip"

peachpuff :: Color
peachpuff = Color "peachpuff"

peru :: Color
peru = Color "peru"

pink :: Color
pink = Color "pink"

plum :: Color
plum = Color "plum"

powderblue :: Color
powderblue = Color "powderblue"

purple :: Color
purple = Color "purple"

rebeccapurple :: Color
rebeccapurple = Color "rebeccapurple"

red :: Color
red = Color "red"

rosybrown :: Color
rosybrown = Color "rosybrown"

royalblue :: Color
royalblue = Color "royalblue"

saddlebrown :: Color
saddlebrown = Color "saddlebrown"

salmon :: Color
salmon = Color "salmon"

sandybrown :: Color
sandybrown = Color "sandybrown"

seagreen :: Color
seagreen = Color "seagreen"

seashell :: Color
seashell = Color "seashell"

sienna :: Color
sienna = Color "sienna"

silver :: Color
silver = Color "silver"

skyblue :: Color
skyblue = Color "skyblue"

slateblue :: Color
slateblue = Color "slateblue"

slategray :: Color
slategray = Color "slategray"

slategrey :: Color
slategrey = Color "slategrey"

snow :: Color
snow = Color "snow"

springgreen :: Color
springgreen = Color "springgreen"

steelblue :: Color
steelblue = Color "steelblue"

tan :: Color
tan = Color "tan"

teal :: Color
teal = Color "teal"

thistle :: Color
thistle = Color "thistle"

tomato :: Color
tomato = Color "tomato"

turquoise :: Color
turquoise = Color "turquoise"

violet :: Color
violet = Color "violet"

wheat :: Color
wheat = Color "wheat"

white :: Color
white = Color "white"

whitesmoke :: Color
whitesmoke = Color "whitesmoke"

yellow :: Color
yellow = Color "yellow"

yellowgreen :: Color
yellowgreen = Color "yellowgreen"

module RNX.Color where

import Prelude

data Color
  = RGBA Int Int Int Number
  | HSLA Int Int Int Number
  | Str String
  | Transparent
  | AliceBlue
  | AntiqueWhite
  | Aqua
  | AquaMarine
  | Azure
  | Beige
  | Bisque
  | Black
  | BlanchedAlmond
  | Blue
  | BlueViolet
  | Brown
  | BurlyWood
  | CadetBlue
  | Chartreuse
  | Chocolate
  | Coral
  | CornFlowerBlue
  | CornSilk
  | Crimson
  | Cyan
  | DarkBlue
  | DarkCyan
  | DarkGoldenRod
  | DarkGray
  | DarkGreen
  | DarkGrey
  | DarkKhaki
  | DarkMagenta
  | DarkOlivegreen
  | DarkOrange
  | DarkOrchid
  | DarkRed
  | DarkSalmon
  | DarkSeaGreen
  | DarkSlateBlue
  | DarkSlateGray
  | DarkSlateGrey
  | DarkTurquoise
  | DarkViolet
  | DeepPink
  | DeepSkyBlue
  | DimGray
  | DimGrey
  | DodgerBlue
  | FireBrick
  | FloralWhite
  | ForestGreen
  | Fuchsia
  | GainsBoro
  | GhostWhite
  | Gold
  | GoldenRod
  | Gray
  | Green
  | GreenYellow
  | Grey
  | HoneyDew
  | HotPink
  | IndianRed
  | Indigo
  | Ivory
  | Khaki
  | Lavender
  | LavenderBlush
  | LawnGreen
  | LemonChiffon
  | LightBlue
  | LightCoral
  | LightCyan
  | LightGoldenRodYellow
  | LightGray
  | LightGreen
  | LightGrey
  | LightPink
  | LightSalmon
  | LightSeaGreen
  | LightSkyBlue
  | LightSlateGray
  | LightSlateGrey
  | LightSteelBlue
  | LightYellow
  | Lime
  | LimeGreen
  | Linen
  | Magenta
  | Maroon
  | MediumAquaMarine
  | MediumBlue
  | MediumOrchid
  | MediumPurple
  | MediumSeaGreen
  | MediumSlateBlue
  | MediumSpringGreen
  | MediumTurquoise
  | MediumVioletRed
  | MidNightBlue
  | MintCream
  | MistyRose
  | Moccasin
  | NavajoWhite
  | Navy
  | OldLace
  | Olive
  | OlivedRab
  | Orange
  | OrangeRed
  | Orchid
  | PaleGoldenRod
  | PaleGreen
  | PaleTurquoise
  | PaleVioletRed
  | PapayaWhip
  | PeachPuff
  | Peru
  | Pink
  | Plum
  | PowderBlue
  | Purple
  | RebeccaPurple
  | Red
  | RosyBrown
  | RoyalBlue
  | SaddleBrown
  | Salmon
  | SandyBrown
  | SeaGreen
  | SeaShell
  | Sienna
  | Silver
  | SkyBlue
  | SlateBlue
  | SlateGray
  | SlateGrey
  | Snow
  | SpringGreen
  | SteelBlue
  | Tan
  | Teal
  | Thistle
  | Tomato
  | Turquoise
  | Violet
  | Wheat
  | White
  | WhiteSmoke
  | Yellow
  | YellowGreen

instance showColor :: Show Color where
  show (RGBA r g b a)       = "rgba(" <> show r <> ", " <> show g <> ", " <> show b <> ", "  <> show a <> ")"
  show (HSLA h s l a)       = "hsl(" <> show h <> "," <> show s  <> "% ," <> show l <> "%, " <> show a <> ")"
  show (Str str)            = str
  show Transparent          = "transparent"
  show AliceBlue            = "aliceblue"
  show AntiqueWhite         = "antiquewhite"
  show Aqua                 = "aqua"
  show AquaMarine           = "aquamarine"
  show Azure                = "azure"
  show Beige                = "beige"
  show Bisque               = "bisque"
  show Black                = "black"
  show BlanchedAlmond       = "blanchedalmond"
  show Blue                 = "blue"
  show BlueViolet           = "blueviolet"
  show Brown                = "brown"
  show BurlyWood            = "burlywood"
  show CadetBlue            = "cadetblue"
  show Chartreuse           = "chartreuse"
  show Chocolate            = "chocolate"
  show Coral                = "coral"
  show CornFlowerBlue       = "cornflowerblue"
  show CornSilk             = "cornsilk"
  show Crimson              = "crimson"
  show Cyan                 = "cyan"
  show DarkBlue             = "darkblue"
  show DarkCyan             = "darkcyan"
  show DarkGoldenRod        = "darkgoldenrod"
  show DarkGray             = "darkgray"
  show DarkGreen            = "darkgreen"
  show DarkGrey             = "darkgrey"
  show DarkKhaki            = "darkkhaki"
  show DarkMagenta          = "darkmagenta"
  show DarkOlivegreen       = "darkolivegreen"
  show DarkOrange           = "darkorange"
  show DarkOrchid           = "darkorchid"
  show DarkRed              = "darkred"
  show DarkSalmon           = "darksalmon"
  show DarkSeaGreen         = "darkseagreen"
  show DarkSlateBlue        = "darkslateblue"
  show DarkSlateGray        = "darkslategray"
  show DarkSlateGrey        = "darkslategrey"
  show DarkTurquoise        = "darkturquoise"
  show DarkViolet           = "darkviolet"
  show DeepPink             = "deeppink"
  show DeepSkyBlue          = "deepskyblue"
  show DimGray              = "dimgray"
  show DimGrey              = "dimgrey"
  show DodgerBlue           = "dodgerblue"
  show FireBrick            = "firebrick"
  show FloralWhite          = "floralwhite"
  show ForestGreen          = "forestgreen"
  show Fuchsia              = "fuchsia"
  show GainsBoro            = "gainsboro"
  show GhostWhite           = "ghostwhite"
  show Gold                 = "gold"
  show GoldenRod            = "goldenrod"
  show Gray                 = "gray"
  show Green                = "green"
  show GreenYellow          = "greenyellow"
  show Grey                 = "grey"
  show HoneyDew             = "honeydew"
  show HotPink              = "hotpink"
  show IndianRed            = "indianred"
  show Indigo               = "indigo"
  show Ivory                = "ivory"
  show Khaki                = "khaki"
  show Lavender             = "lavender"
  show LavenderBlush        = "lavenderblush"
  show LawnGreen            = "lawngreen"
  show LemonChiffon         = "lemonchiffon"
  show LightBlue            = "lightblue"
  show LightCoral           = "lightcoral"
  show LightCyan            = "lightcyan"
  show LightGoldenRodYellow = "lightgoldenrodyellow"
  show LightGray            = "lightgray"
  show LightGreen           = "lightgreen"
  show LightGrey            = "lightgrey"
  show LightPink            = "lightpink"
  show LightSalmon          = "lightsalmon"
  show LightSeaGreen        = "lightseagreen"
  show LightSkyBlue         = "lightskyblue"
  show LightSlateGray       = "lightslategray"
  show LightSlateGrey       = "lightslategrey"
  show LightSteelBlue       = "lightsteelblue"
  show LightYellow          = "lightyellow"
  show Lime                 = "lime"
  show LimeGreen            = "limegreen"
  show Linen                = "linen"
  show Magenta              = "magenta"
  show Maroon               = "maroon"
  show MediumAquaMarine     = "mediumaquamarine"
  show MediumBlue           = "mediumblue"
  show MediumOrchid         = "mediumorchid"
  show MediumPurple         = "mediumpurple"
  show MediumSeaGreen       = "mediumseagreen"
  show MediumSlateBlue      = "mediumslateblue"
  show MediumSpringGreen    = "mediumspringgreen"
  show MediumTurquoise      = "mediumturquoise"
  show MediumVioletRed      = "mediumvioletred"
  show MidNightBlue         = "midnightblue"
  show MintCream            = "mintcream"
  show MistyRose            = "mistyrose"
  show Moccasin             = "moccasin"
  show NavajoWhite          = "navajowhite"
  show Navy                 = "navy"
  show OldLace              = "oldlace"
  show Olive                = "olive"
  show OlivedRab            = "olivedrab"
  show Orange               = "orange"
  show OrangeRed            = "orangered"
  show Orchid               = "orchid"
  show PaleGoldenRod        = "palegoldenrod"
  show PaleGreen            = "palegreen"
  show PaleTurquoise        = "paleturquoise"
  show PaleVioletRed        = "palevioletred"
  show PapayaWhip           = "papayawhip"
  show PeachPuff            = "peachpuff"
  show Peru                 = "peru"
  show Pink                 = "pink"
  show Plum                 = "plum"
  show PowderBlue           = "powderblue"
  show Purple               = "purple"
  show RebeccaPurple        = "rebeccapurple"
  show Red                  = "red"
  show RosyBrown            = "rosybrown"
  show RoyalBlue            = "royalblue"
  show SaddleBrown          = "saddlebrown"
  show Salmon               = "salmon"
  show SandyBrown           = "sandybrown"
  show SeaGreen             = "seagreen"
  show SeaShell             = "seashell"
  show Sienna               = "sienna"
  show Silver               = "silver"
  show SkyBlue              = "skyblue"
  show SlateBlue            = "slateblue"
  show SlateGray            = "slategray"
  show SlateGrey            = "slategrey"
  show Snow                 = "snow"
  show SpringGreen          = "springgreen"
  show SteelBlue            = "steelblue"
  show Tan                  = "tan"
  show Teal                 = "teal"
  show Thistle              = "thistle"
  show Tomato               = "tomato"
  show Turquoise            = "turquoise"
  show Violet               = "violet"
  show Wheat                = "wheat"
  show White                = "white"
  show WhiteSmoke           = "whitesmoke"
  show Yellow               = "yellow"
  show YellowGreen          = "yellowgreen"

rgb :: Int -> Int -> Int -> Color
rgb r g b =
  rgba r g b 1.0

rgba :: Int -> Int -> Int -> Number -> Color
rgba r g b a =
    RGBA r g b a

hsl :: Int -> Int -> Int -> Color
hsl h s l  =
  hsla h s l 1.0

hsla :: Int -> Int -> Int -> Number -> Color
hsla h s l a  =
  HSLA h s l a

strColor :: String -> Color
strColor = Str


add documentation to IDBObjectStore

add documentation to IDBObjectStore

-- | An object store is the primary storage mechanism for storing data in a database.
module Database.IndexedDB.IDBObjectStore
  ( class IDBObjectStore, add, clear, createIndex, delete, deleteIndex, index, put
  , module Database.IndexedDB.IDBIndex.Internal
  , IDBObjectStoreParameters
  , IndexName
  , autoIncrement
  , indexNames
  , keyPath
  , name
  , transaction
  , defaultParameters
  ) where

import Prelude                              (Unit, ($), (<$>), (>>>))

import Control.Monad.Aff                    (Aff)
import Data.Foreign                         (Foreign)
import Data.Function.Uncurried               as Fn
import Data.Function.Uncurried              (Fn2, Fn3, Fn4)
import Data.Maybe                           (Maybe)
import Data.Nullable                        (Nullable, toNullable)

import Database.IndexedDB.Core              (IDB, Index, KeyRange, KeyPath, ObjectStore, Transaction)
import Database.IndexedDB.IDBIndex.Internal (class IDBIndex, IDBIndexParameters, count, get, getAllKeys, getKey, openCursor, openKeyCursor)
import Database.IndexedDB.IDBKey.Internal   (class IDBKey, Key(Key), extractForeign, toKey)

--------------------
-- INTERFACES
--
-- | The IDBObjectStore interface represents an object store handle.
class IDBObjectStore store where
  -- | Adds or updates a record in store with the given value and key.
  -- |
  -- | If the store uses in-line keys and key is specified a "DataError" DOMException
  -- | will be thrown.
  -- |
  -- | If add() is used, and if a record with the key already exists the request will fail,
  -- | with a "ConstraintError" DOMException.
  add :: forall v k e. (IDBKey k) => store -> v -> Maybe k -> Aff (idb :: IDB | e) Key

  -- | Deletes all records in store.
  clear :: forall e. store -> Aff (idb :: IDB | e) Unit

  -- | Creates a new index in store with the given name, keyPath and options and
  -- | returns a new IDBIndex. If the keyPath and options define constraints that
  -- | cannot be satisfied with the data already in store the upgrade transaction
  -- | will abort with a "ConstraintError" DOMException.
  -- |
  -- | Throws an "InvalidStateError" DOMException if not called within an upgrade transaction.
  createIndex :: forall e. store -> IndexName -> KeyPath -> IDBIndexParameters -> Aff (idb :: IDB | e) Index

  -- | Deletes records in store with the given key or in the given key range in query.
  delete :: forall e. store -> KeyRange -> Aff (idb :: IDB | e) Unit

  -- | Deletes the index in store with the given name.
  -- |
  -- | Throws an "InvalidStateError" DOMException if not called within an upgrade transaction.
  deleteIndex :: forall e. store -> IndexName -> Aff (idb :: IDB | e) Unit

  -- | Returns an IDBIndex for the index named name in store.
  index :: forall e. store -> IndexName -> Aff (idb :: IDB | e) Index

  -- | Adds or updates a record in store with the given value and key.
  -- |
  -- | If the store uses in-line keys and key is specified a "DataError" DOMException
  -- | will be thrown.
  -- |
  -- | If put() is used, any existing record with the key will be replaced.
  put :: forall v k e. (IDBKey k) => store -> v -> Maybe k -> Aff (idb :: IDB | e) Key

-- | Type alias for IndexName
type IndexName = String

-- | Options provided when creating an object store.
type IDBObjectStoreParameters =
  { keyPath       :: KeyPath
  , autoIncrement :: Boolean
  }

defaultParameters :: IDBObjectStoreParameters
defaultParameters =
  { keyPath       : []
  , autoIncrement : false
  }

--------------------
-- ATTRIBUTES
--
-- | Returns `true` if the store has a key generator, and `false` otherwise.
autoIncrement
  :: ObjectStore
  -> Boolean
autoIncrement =
  _autoIncrement

--| Returns a list of the names of indexes in the store.
indexNames
  :: ObjectStore
  -> Array String
indexNames =
  _indexNames

-- | Returns the key path of the store, or empty array if none
keyPath
  :: ObjectStore
  -> Array String
keyPath =
  _keyPath

-- | Returns the name of the store.
name
  :: ObjectStore
  -> String
name =
  _name

-- | Returns the associated transaction.
transaction
  :: ObjectStore
  -> Transaction
transaction =
  _transaction

--------------------
-- INSTANCES
--
instance idbObjectStoreObjectStore :: IDBObjectStore ObjectStore where
  add store value key =
    Key <$> Fn.runFn3 _add store value (toNullable $ (toKey >>> extractForeign) <$> key)

  clear =
    _clear

  createIndex store name' path params =
    Fn.runFn4 _createIndex store name' path params

  delete store range =
    Fn.runFn2 _delete store range

  deleteIndex store name' =
    Fn.runFn2 _deleteIndex store name'

  index store name' =
    Fn.runFn2 _index store name'

  put store value key =
    Key <$> Fn.runFn3 _put store value (toNullable $ (toKey >>> extractForeign) <$> key)

--------------------
-- FFI
--
foreign import _add
  :: forall value e
  .  Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _autoIncrement
  :: ObjectStore
  -> Boolean

foreign import _clear
  :: forall e
  .  ObjectStore
  -> Aff (idb :: IDB | e) Unit

foreign import _createIndex
  :: forall e
  .  Fn4 ObjectStore String (Array String) { unique :: Boolean, multiEntry :: Boolean } (Aff (idb :: IDB | e) Index)

foreign import _delete
  :: forall e
  .  Fn2 ObjectStore KeyRange (Aff (idb :: IDB | e) Unit)

foreign import _deleteIndex
  :: forall e
  .  Fn2 ObjectStore String (Aff (idb :: IDB | e) Unit)

foreign import _index
  :: forall e
  .  Fn2 ObjectStore String (Aff (idb :: IDB | e) Index)

foreign import _indexNames
  :: ObjectStore
  -> Array String

foreign import _keyPath
  :: ObjectStore
  -> Array String

foreign import _name
  :: ObjectStore
  -> String

foreign import _put
  :: forall value e
  .  Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _transaction
  :: ObjectStore
  -> Transaction

module Database.IndexedDB.IDBObjectStore
  ( class IDBObjectStore, add, clear, createIndex, delete, deleteIndex, index, put
  , module Database.IndexedDB.IDBIndex.Internal
  , IDBObjectStoreParameters
  , IndexName
  , autoIncrement
  , indexNames
  , keyPath
  , name
  , transaction
  , defaultParameters
  ) where

import Prelude                              (Unit, ($), (<$>), (>>>))

import Control.Monad.Aff                    (Aff)
import Data.Foreign                         (Foreign)
import Data.Function.Uncurried               as Fn
import Data.Function.Uncurried              (Fn2, Fn3, Fn4)
import Data.Maybe                           (Maybe)
import Data.Nullable                        (Nullable, toNullable)

import Database.IndexedDB.Core              (IDB, Index, KeyRange, KeyPath, ObjectStore, Transaction)
import Database.IndexedDB.IDBIndex.Internal (class IDBIndex, IDBIndexParameters, count, get, getAllKeys, getKey, openCursor, openKeyCursor)
import Database.IndexedDB.IDBKey.Internal   (class IDBKey, Key(Key), extractForeign, toKey)

--------------------
-- INTERFACES
--
class IDBObjectStore store where
  add :: forall v k e. (IDBKey k) => store -> v -> Maybe k -> Aff (idb :: IDB | e) Key
  clear :: forall e. store -> Aff (idb :: IDB | e) Unit
  createIndex :: forall e. store -> IndexName -> KeyPath -> IDBIndexParameters -> Aff (idb :: IDB | e) Index
  delete :: forall e. store -> KeyRange -> Aff (idb :: IDB | e) Unit
  deleteIndex :: forall e. store -> IndexName -> Aff (idb :: IDB | e) Unit
  index :: forall e. store -> IndexName -> Aff (idb :: IDB | e) Index
  put :: forall v k e. (IDBKey k) => store -> v -> Maybe k -> Aff (idb :: IDB | e) Key

type IndexName = String

type IDBObjectStoreParameters =
  { keyPath       :: KeyPath
  , autoIncrement :: Boolean
  }

--------------------
-- ATTRIBUTES
--
autoIncrement :: ObjectStore -> Boolean
autoIncrement =
  _autoIncrement

indexNames :: ObjectStore -> Array String
indexNames =
  _indexNames

keyPath :: ObjectStore -> Array String
keyPath =
  _keyPath

name :: ObjectStore -> String
name =
  _name

transaction :: ObjectStore -> Transaction
transaction =
  _transaction

--------------------
-- INSTANCES
--
instance idbObjectStoreObjectStore :: IDBObjectStore ObjectStore where
  add store value key =
    Key <$> Fn.runFn3 _add store value (toNullable $ (toKey >>> extractForeign) <$> key)

  clear =
    _clear

  createIndex store name' path params =
    Fn.runFn4 _createIndex store name' path params

  delete store range =
    Fn.runFn2 _delete store range

  deleteIndex store name' =
    Fn.runFn2 _deleteIndex store name'

  index store name' =
    Fn.runFn2 _index store name'

  put store value key =
    Key <$> Fn.runFn3 _put store value (toNullable $ (toKey >>> extractForeign) <$> key)

defaultParameters :: IDBObjectStoreParameters
defaultParameters =
  { keyPath       : []
  , autoIncrement : false
  }

--------------------
-- FFI
--
foreign import _add :: forall value e. Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _autoIncrement :: ObjectStore -> Boolean

foreign import _clear :: forall e. ObjectStore -> Aff (idb :: IDB | e) Unit

foreign import _createIndex :: forall e. Fn4 ObjectStore String (Array String) { unique :: Boolean, multiEntry :: Boolean } (Aff (idb :: IDB | e) Index)

foreign import _delete :: forall e. Fn2 ObjectStore KeyRange (Aff (idb :: IDB | e) Unit)

foreign import _deleteIndex :: forall e. Fn2 ObjectStore String (Aff (idb :: IDB | e) Unit)

foreign import _index :: forall e. Fn2 ObjectStore String (Aff (idb :: IDB | e) Index)

foreign import _indexNames :: ObjectStore -> Array String

foreign import _keyPath :: ObjectStore -> Array String

foreign import _name :: ObjectStore -> String

foreign import _put :: forall value e. Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _transaction :: ObjectStore -> Transaction


don't parse in multiple places, prepare data on fetch

module FrontEnd where

import Prelude

import CSS (backgroundImage, url)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Either (Either(..), either, hush)
import Data.JSDate as JSDate
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, isJust, isNothing, maybe)
import Data.Newtype (unwrap, wrap)
import Data.Set (Set, insert, member)
import Data.String (Pattern(Pattern), contains, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect)
import Effect.Class.Console (error, errorShow, log)
import Effect.Unsafe (unsafePerformEffect)
import FrontEnd.Chart as Chart
import FrontEnd.Style (classNames)
import Global.Unsafe (unsafeEncodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS (style)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Milkis as M
import Milkis.Impl.Window (windowFetch)
import NameParser (nameParser)
import Routes (GetRoute, PostRoute, apiRoutes)
import Simple.JSON as JSON
import Text.Parsing.StringParser (runParser)
import Types (Path(..), WatchedData)

get
  :: forall res url m
   . MonadAff m
  => JSON.ReadForeign res
  => IsSymbol url
  => GetRoute res url -> m (JSON.E res)
get _ =
  H.liftAff $ JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    action = M.json =<< fetch (M.URL url) M.defaultFetchOptions

post
  :: forall req res url m
   . MonadAff m
  => JSON.WriteForeign req
  => JSON.ReadForeign res
  => IsSymbol url
  => PostRoute req res url -> req -> m (JSON.E res)
post _ body =
  H.liftAff $ JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    options =
      { method: M.postMethod
      , headers: M.makeHeaders { "Content-Type": "application/json" }
      , body: JSON.writeJSON body
      }
    action = M.json =<< fetch (M.URL url) options

unE :: forall a m. MonadEffect m => (a -> m Unit) -> JSON.E a -> m Unit
unE = either errorShow

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = TitleEpisode | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

data RemoteTaskState
  = Standby
  | Working
  | Success
  | Failure

type State =
  { fileData :: Array FileData
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , deleteConfirmations :: Set Path
  , getIcons :: RemoteTaskState
  }

type FileData =
  { path :: Path
  , name :: Maybe String
  , episode :: Maybe String
  , created :: Maybe String
  }

prepareFilesData :: Array Path -> Array WatchedData -> Array FileData
prepareFilesData paths watchedData =
  go <$> paths
  where
    go path@(Path pathString) = do
      let parsed = hush $ runParser nameParser pathString
      { path
      , created: _.created <$> Array.find (\x -> x.path == path) watchedData
      , name: _.name <$> parsed
      , episode: _.episode <$> parsed
      }

data Query a
  = Init a
  | FetchData a
  | GetIcons a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter (Maybe String) a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a
  | ConfirmDeletion Path a
  | Delete Path a

type ChildSlots =
  ( chart :: Chart.Slot Unit
  )

ui :: H.Component HH.HTML Query Unit Void Aff
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { fileData: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , deleteConfirmations: mempty
      , getIcons: Standby
      }

    render :: State -> H.ComponentHTML Query ChildSlots Aff
    render state =
      HH.div
        [ HP.class_ $ classNames.container ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , getIconsButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.slot (SProxy :: SProxy "chart") unit Chart.component state.watched absurd
        refreshButton =
          HH.button
            [ HP.classes $
              [ classNames.refreshFiles
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        getIconsButton =
          HH.button
            [ HP.classes $
              [ classNames.getIcons
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ GetIcons
            ]
            [ HH.text
               $ "Run Get Icons"
              <> case state.getIcons of
                   Standby -> ": Standby"
                   Working -> ": Working..."
                   Success -> ": Success"
                   Failure -> ": Failed"
            ]
        filterCheckbox =
          HH.button
            [ HP.classes $
              [ classNames.filterWatched
              , wrap "pure-button"
              ] <> (guard state.filterWatched $> wrap "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div_
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ classNames.file]
            [ HH.h3
              [ HP.class_ $ classNames.dot
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileLink
              , HE.onClick $ HE.input_ (ChangeSorting TitleEpisode)
              ] [ HH.text $ "Title" <> displayTicker TitleEpisode ]
            , HH.h3
              [ HP.class_ $ classNames.fileEpisode
              , HE.onClick $ HE.input_ (ChangeSorting TitleEpisode)
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileButton
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ classNames.fileNote ] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ classNames.filterLink
              ] [ HH.text "" ]
            , HH.h3
              [ HP.class_ $ classNames.deleteLink
              ] [ HH.text "" ]
            ]
        files = file <$> applyTransforms state.fileData

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms
            = applySorting
          <<< applySearchFiltering
          <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then Array.filter $ isNothing <<< _.created
          else identity
        applySearchFiltering = case state.search of
            "" -> identity
            x -> Array.filter $ \{ path: Path path } -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then identity
            else Array.reverse
          , sort' <- case col of
            TitleEpisode -> \xs -> do
              let
                grouped = Array.groupBy (\{name: nameA} {name: nameB} -> nameA == nameB) xs
                sorted = Array.sortWith _.episode <<< Array.fromFoldable <$> grouped
              join sorted
            Status -> Array.sortWith _.created
            _ -> identity
          = rev <<< sort'
          | otherwise = identity
        parseEpisodeNumber { path: Path path } = case runParser nameParser path of
          Right {episode} -> episode
          Left _ -> "999"
        file { path, created, name, episode } =
          HH.div
            [ HP.class_ $ classNames.file ]
            [ HH.span
              [ HP.class_ $ classNames.dot
              , style do
                case name of
                  Just s ->
                    backgroundImage (url $ "icons/" <> unsafeEncodeURIComponent s)
                  Nothing -> pure mempty
              ] []
            , HH.a
              [ HP.class_ classNames.fileLink
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.span
                [ HP.class_ $ classNames.fileEpisode ]
                [ HH.text $ fromMaybe "" episode ]
            , HH.button
              [ HP.classes $
                [ classNames.fileButton
                , wrap "pure-button"
                , wrap $ maybe "" (const "pure-button-primary") watchedDate
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watchedDate))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watchedDate ]
            , HH.span
              [ HP.class_ $ classNames.fileNote ]
              [ HH.text $ maybe "" identity watchedDate ]
            , HH.button
              [ HP.classes $
                [ classNames.filterLink
                , wrap "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter name)
              ]
              [ HH.text "set filter" ]
            , HH.button
              [ HP.classes $
                [ classNames.deleteLink
                , wrap "pure-button"
                , if deleteConfirmation
                    then classNames.deleteConfirmation
                    else wrap ""
                ]
              , HE.onClick $ HE.input_ $
                  if deleteConfirmation
                    then (Delete path)
                    else (ConfirmDeletion path)
              ]
              [ HH.text
                  if deleteConfirmation
                    then "Confirm"
                    else "Delete"
              ]
            ]
          where
            watchedDate = getDate <$> created
            deleteConfirmation = member path state.deleteConfirmations
            getDate dateString =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEffect <<< JSDate.parse $ dateString

    eval :: Query ~> H.HalogenM State Query ChildSlots Void Aff
    eval (Init next) = do
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unE
        \{filesData: fd, watched: w} -> do
          H.modify_ _ {fileData = fd, watched = w}
      pure next
      where
        getResult = do
          files <- get apiRoutes.files
          watched <- get apiRoutes.watched
          let filesData = prepareFilesData <$> files <*> watched
          pure $ { filesData: _, watched: _ } <$> filesData <*> watched

    eval (GetIcons next) = do
      H.modify_ _ {getIcons = Working}
      result <- post apiRoutes.getIcons {}
      case result of
        Right {success} | success -> H.modify_ _ {getIcons = Success}
        _ -> H.modify_ _ {getIcons = Failure}
      pure next

    eval (OpenFile path next) = do
      _ <- post apiRoutes.open {path}
      pure next

    eval (SetWatched path flag next) = do
      post apiRoutes.update {path, watched: flag}
        >>= unE \w -> H.modify_ _ {watched = w}
      pure next

    eval (Filter name next) = do
      case name of
        Nothing -> error "Can't filter by unknown name" *> pure next
        Just s -> eval $ Search s next

    eval (Search str next) = do
      H.modify_ _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify_ _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify_ $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify_ _ {filterWatched = flag}
      pure next

    eval (ConfirmDeletion path next) = do
      H.modify_ \s -> s {deleteConfirmations = insert path s.deleteConfirmations}
      pure next

    eval (Delete path next) = do
      _ <- post apiRoutes.remove {path}
      eval (FetchData next)

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log $ "Running"

module FrontEnd where

import Prelude

import CSS (backgroundImage, url)
import Control.MonadPlus (guard)
import Data.Array (filter, reverse, sort, sortWith)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either)
import Data.JSDate as JSDate
import Data.Maybe (Maybe(Nothing, Just), isJust, isNothing, maybe)
import Data.Newtype (unwrap, wrap)
import Data.Set (Set, insert, member)
import Data.String (Pattern(Pattern), contains, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (find)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect)
import Effect.Class.Console (error, errorShow, log)
import Effect.Unsafe (unsafePerformEffect)
import Foreign (MultipleErrors)
import FrontEnd.Chart as Chart
import FrontEnd.Style (classNames)
import Global.Unsafe (unsafeEncodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS (style)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Milkis as M
import Milkis.Impl.Window (windowFetch)
import NameParser (nameParser)
import Routes (GetRoute, PostRoute, apiRoutes)
import Simple.JSON (class ReadForeign, class WriteForeign, read, writeJSON)
import Text.Parsing.StringParser (runParser)
import Types (Path(..), WatchedData)

extractNameKinda :: Path -> Either String String
extractNameKinda (Path s) =
  bimap show _.name $ runParser nameParser s

type E a = Either MultipleErrors a

get
  :: forall res url m
   . MonadAff m
  => ReadForeign res
  => IsSymbol url
  => GetRoute res url -> m (E res)
get _ =
  H.liftAff $ read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    action = M.json =<< fetch (M.URL url) M.defaultFetchOptions

post
  :: forall req res url m
   . MonadAff m
  => WriteForeign req
  => ReadForeign res
  => IsSymbol url
  => PostRoute req res url -> req -> m (E res)
post _ body =
  H.liftAff $ read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    options =
      { method: M.postMethod
      , headers: M.makeHeaders { "Content-Type": "application/json" }
      , body: writeJSON body
      }
    action = M.json =<< fetch (M.URL url) options

unE :: forall a m. MonadEffect m => (a -> m Unit) -> E a -> m Unit
unE = either errorShow

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status | Episode
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

data RemoteTaskState
  = Standby
  | Working
  | Success
  | Failure

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , deleteConfirmations :: Set Path
  , getIcons :: RemoteTaskState
  }

data Query a
  = Init a
  | FetchData a
  | GetIcons a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter Path a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a
  | ConfirmDeletion Path a
  | Delete Path a

type ChildSlots =
  ( chart :: Chart.Slot Unit
  )

ui :: H.Component HH.HTML Query Unit Void Aff
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , deleteConfirmations: mempty
      , getIcons: Standby
      }

    render :: State -> H.ComponentHTML Query ChildSlots Aff
    render state =
      HH.div
        [ HP.class_ $ classNames.container ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , getIconsButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.slot (SProxy :: SProxy "chart") unit Chart.component state.watched absurd
        refreshButton =
          HH.button
            [ HP.classes $
              [ classNames.refreshFiles
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        getIconsButton =
          HH.button
            [ HP.classes $
              [ classNames.getIcons
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ GetIcons
            ]
            [ HH.text
               $ "Run Get Icons"
              <> case state.getIcons of
                   Standby -> ": Standby"
                   Working -> ": Working..."
                   Success -> ": Success"
                   Failure -> ": Failed"
            ]
        filterCheckbox =
          HH.button
            [ HP.classes $
              [ classNames.filterWatched
              , wrap "pure-button"
              ] <> (guard state.filterWatched $> wrap "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div_
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ classNames.file]
            [ HH.h3
              [ HP.class_ $ classNames.dot
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileLink
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ classNames.fileEpisode
              , HE.onClick $ HE.input_ (ChangeSorting Episode)
              ] [ HH.text $ "No" <> displayTicker Episode ]
            , HH.h3
              [ HP.class_ $ classNames.fileButton
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ classNames.fileNote ] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ classNames.filterLink
              ] [ HH.text "" ]
            , HH.h3
              [ HP.class_ $ classNames.deleteLink
              ] [ HH.text "" ]
            ]
        files =
          file <$> applyTransforms state.files

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applySearchFiltering <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then filter $ isNothing <<< findWatched
          else identity
        applySearchFiltering = case state.search of
            "" -> identity
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then identity
            else reverse
          , sort' <- case col of
            Title -> sort
            Episode -> sortWith parseEpisodeNumber
            Status -> sortWith (map _.created <<< findWatched)
            _ -> identity
          = rev <<< sort'
          | otherwise = identity
        parseEpisodeNumber (Path path) = case runParser nameParser path of
          Right {episode} -> episode
          Left _ -> "999"
        findWatched path = find (\fd -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ classNames.file ]
            [ HH.span
              [ HP.class_ $ classNames.dot
              , style do
                case extractNameKinda path of
                  Right name ->
                    backgroundImage (url $ "icons/" <> unsafeEncodeURIComponent name)
                  Left e -> pure mempty
              ] []
            , HH.a
              [ HP.class_ classNames.fileLink
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.span
                [ HP.class_ $ classNames.fileEpisode ]
                [ HH.text $ either (const "") _.episode $ runParser nameParser (unwrap path) ]
            , HH.button
              [ HP.classes $
                [ classNames.fileButton
                , wrap "pure-button"
                , wrap $ maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ classNames.fileNote ]
              [ HH.text $ maybe "" identity watched ]
            , HH.button
              [ HP.classes $
                [ classNames.filterLink
                , wrap "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter path)
              ]
              [ HH.text "set filter" ]
            , HH.button
              [ HP.classes $
                [ classNames.deleteLink
                , wrap "pure-button"
                , if deleteConfirmation
                    then classNames.deleteConfirmation
                    else wrap ""
                ]
              , HE.onClick $ HE.input_ $
                  if deleteConfirmation
                    then (Delete path)
                    else (ConfirmDeletion path)
              ]
              [ HH.text
                  if deleteConfirmation
                    then "Confirm"
                    else "Delete"
              ]
            ]
          where
            watched = getDate <$> findWatched path
            deleteConfirmation = member path state.deleteConfirmations
            getDate {created} =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEffect <<< JSDate.parse $ created

    eval :: Query ~> H.HalogenM State Query ChildSlots Void Aff
    eval (Init next) = do
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unE
        \(Tuple f w) -> do
          H.modify_ _ {files = f, watched = w}
      pure next
      where
        getResult = do
          files <- get apiRoutes.files
          watched <- get apiRoutes.watched
          pure $ Tuple <$> files <*> watched

    eval (GetIcons next) = do
      H.modify_ _ {getIcons = Working}
      result <- post apiRoutes.getIcons {}
      case result of
        Right {success} | success -> H.modify_ _ {getIcons = Success}
        _ -> H.modify_ _ {getIcons = Failure}
      pure next

    eval (OpenFile path next) = do
      _ <- post apiRoutes.open {path}
      pure next

    eval (SetWatched path flag next) = do
      post apiRoutes.update {path, watched: flag}
        >>= unE \w -> H.modify_ _ {watched = w}
      pure next

    eval (Filter path next) = do
      case extractNameKinda path of
        Left e -> error e *> pure next
        Right s -> eval $ Search s next

    eval (Search str next) = do
      H.modify_ _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify_ _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify_ $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify_ _ {filterWatched = flag}
      pure next

    eval (ConfirmDeletion path next) = do
      H.modify_ \s -> s {deleteConfirmations = insert path s.deleteConfirmations}
      pure next

    eval (Delete path next) = do
      _ <- post apiRoutes.remove {path}
      eval (FetchData next)

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log $ "Running"


Fixed typo

Fixed typo

module GameData where

import Data.Tuple
import Data.Array (map)
import Data.String
import Data.Monoid
import Data.Foldable
import qualified Data.Map as M
import Utils
import Math

type Point = { x :: Number, y :: Number }

(.+.) :: Point -> Point -> Point
(.+.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1+x2, y: y1+y2}
infixl 9 .+.

(.-.) :: Point -> Point -> Point
(.-.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1-x2, y: y1-y2}
infixl 9 .-.

(.==.) :: Point -> Point -> Boolean
(.==.) {x = x1, y = y1} {x = x2, y = y2} = x1 == x2 && y1 == y2

showPoint :: Point -> String
showPoint p = "(" ++ show p.x ++ ", " ++ show p.y ++ ")"

manhattanDistance :: Point -> Point -> Number
manhattanDistance {x = x1, y = y1} {x = x2, y=y2} = abs (x1 - x2) + abs (y1 - y2)

distanceSq :: Point -> Point -> Number
distanceSq {x = x1, y = y1} {x = x2, y=y2} = (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

zerop :: Point
zerop = {x: 0, y: 0}

unitp :: Point -> Point
unitp p = {x: sign p.x, y: sign p.y}

type Stats =
    { maxHp :: Number
    , hp    :: Number
    , str   :: Number
    , dex   :: Number
    , int   :: Number
    }

defaultStats :: Stats
defaultStats = { maxHp: 10, hp: 10, str: 10, dex: 10, int: 10 }

guardStats :: Stats
guardStats = { maxHp: 20, hp: 20, str: 8, dex: 8, int: 10 }

archerStats :: Stats
archerStats = { maxHp: 10, hp: 10, str: 6, dex: 10, int: 10 }

statsToString :: Stats -> String
statsToString { maxHp = mh, hp  = h, str = s, dex = d, int = i } = "Hp: " ++ show h ++ "/" ++ show mh ++ ". Str: " ++ show s ++ ". Dex: " ++ show d ++ ". Int: " ++ show i ++"."
statsToString _ = ""

statModf :: Number -> Number
statModf x = -5 + floor (x / 2)

data SkillType = WeaponSkill | Sneak | Athletics | Lockpick

type Skill = { level :: Number, prog :: Number }

type Skills = M.Map SkillType Skill

instance showSkillType :: Show SkillType where
    show WeaponSkill = "weapon"
    show Sneak       = "sneaking"
    show Athletics   = "athletics"
    show Lockpick    = "lockpicking"

instance ordSkillType :: Ord SkillType where
    compare a b = compare (show a) (show b)

instance eqSkillType :: Eq SkillType where
    (==) a b = show a == show b
    (/=) a b = not (a == b)

defaultSkills :: Skills
defaultSkills = M.fromList [Tuple WeaponSkill {level: 0, prog: 0}
                           ,Tuple Sneak { level: 0, prog: 0}
                           ,Tuple Athletics { level: 0, prog: 0}
                           ,Tuple Lockpick { level: 0, prog: 0}
                           ]

startingClass :: [String]
startingClass = ["the knight", "the monk", "the ninja", "the peasant", "the rogue", "the scholar", "the skillmaster", "the soldier", "the developer"]

startingStats :: [Stats]
startingStats = [ { maxHp: 10, hp: 10, str: 14, dex:  9, int: 10 } -- Knight
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 12 } -- Monk
                , { maxHp: 10, hp: 10, str:  9, dex: 14, int: 10 } -- Ninja
                , { maxHp:  9, hp:  9, str:  9, dex:  9, int:  9 } -- Peasant
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 11 } -- Rogue
                , { maxHp: 10, hp: 10, str: 09, dex: 11, int: 13 } -- Scholar
                , { maxHp: 10, hp: 10, str: 10, dex: 10, int: 11 } -- Skillmaster
                , { maxHp: 10, hp: 10, str: 12, dex: 11, int: 10 } -- Soldier
                , { maxHp: 99, hp: 99, str: 99, dex: 99, int: 99 } -- Developer
                ]

startingSkillpoints :: [Number]
startingSkillpoints = [ 2 -- Knight
                      , 2 -- Monk
                      , 2 -- Ninja
                      , 1 -- Peasant
                      , 5 -- Rogue
                      , 5 -- Scholar
                      , 8 -- Skillmaster
                      , 2 -- Soldier
                      , 99 -- Developer
                      ]

skillsInfo :: Skills -> String
skillsInfo skills = skillsToString $ M.toList skills
    where
        skillToString :: Tuple SkillType Skill -> String
        skillToString (Tuple sType { level = l, prog = p }) = fill (show sType ++ " skill. ") 21 ++ fill (" Level: " ++ show l ++ ".") 11 ++ " Progress (0 - " ++ show (100 + l * 50) ++ "): " ++ show p ++"\n"

        skillsToString :: [Tuple SkillType Skill] -> String
        skillsToString [] = ""
        skillsToString (x:xs) = skillToString x ++ ("\n") ++ skillsToString xs

data CreatureType = Player | Guard | Archer | Peasant

instance showCT :: Show CreatureType where
    show Player  = "player"
    show Guard   = "guard"
    show Archer  = "archer"
    show Peasant = "peasant"

instance eqCT :: Eq CreatureType where
    (==) a b = show a == show b
    (/=) a b = show a /= show b

data AIState = Sleep
             | Idle Point   -- idling position
             | Patrol Point -- where to go

data Alertness = NoAlert  -- Does not see player
               | MightSee -- There is LOS and a chance to turn into Suspicious
               | Suspicious Number -- Number = progress towards alert
               | Alert Number -- Number = number of turns to stay alert

data AI = AI Alertness AIState | NoAI

type Creature =
    { pos   :: Point -- Position
    , dir   :: Point -- Facing direction
    , ctype :: CreatureType
    , stats :: Stats
    , time  :: Number
    , vel   :: Point -- Velocity
    , ai    :: AI
    }

--------- ARMOR STAT ---------

type ArmorStatRecord = { defence :: Number, weight :: Number }

data ArmorStat = ArmorStat ArmorStatRecord

extractStatArmor :: ArmorStat -> ArmorStatRecord
extractStatArmor (ArmorStat s) = s

instance semigroupArmorStat :: Semigroup ArmorStat where
    (<>) (ArmorStat a) (ArmorStat b) =
        ArmorStat { defence: a.defence + b.defence
                  , weight: a.weight + b.weight
                  }

instance monoidArmorStat :: Monoid ArmorStat where
    mempty = ArmorStat { defence: 0, weight: 0 }

--------- WEAPON STAT ---------

type WeaponStatRecord = { damage :: Number, weight :: Number, attackSpeed :: Number, attackBonus :: Number }

data WeaponStat = WeaponStat WeaponStatRecord

extractStatWeapon :: WeaponStat -> WeaponStatRecord
extractStatWeapon (WeaponStat s) = s

instance semigroupWeaponStat :: Semigroup WeaponStat where
    (<>) (WeaponStat a) (WeaponStat b) =
        WeaponStat { damage: a.damage + b.damage
                   , weight: a.weight + b.weight
                   , attackSpeed: a.attackSpeed + b.attackSpeed
                   , attackBonus: a.attackBonus + b.attackBonus
                   }

instance monoidWeaponStat :: Monoid WeaponStat where
    mempty = WeaponStat { damage: 0, weight: 0, attackSpeed: 0, attackBonus: 0 }

--------- MATERIALS ---------

data Material = Wood | Copper | Iron | Steel | Titanium | Adamantine | Leather

materialStatWeapon :: Material -> WeaponStat
materialStatWeapon Wood       = WeaponStat { damage: -3, weight: -1, attackSpeed:  -50, attackBonus: 4 }
materialStatWeapon Copper     = WeaponStat { damage: -1, weight:  1, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Iron       = WeaponStat { damage:  0, weight:  2, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Steel      = WeaponStat { damage:  1, weight:  3, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Titanium   = WeaponStat { damage:  2, weight:  4, attackSpeed:    0, attackBonus: 0 }
materialStatWeapon Adamantine = WeaponStat { damage:  3, weight:  4, attackSpeed: -100, attackBonus: 1 }
materialStatWeapon _ = mempty

materialStatArmor :: Material -> ArmorStat
materialStatArmor Leather    = ArmorStat { defence: 1, weight: 10 }
materialStatArmor Copper     = ArmorStat { defence: 2, weight: 30 }
materialStatArmor Iron       = ArmorStat { defence: 3, weight: 35 }
materialStatArmor Steel      = ArmorStat { defence: 4, weight: 45 }
materialStatArmor Titanium   = ArmorStat { defence: 5, weight: 60 }
materialStatArmor Adamantine = ArmorStat { defence: 7, weight: 60 }
materialStatArmor _ = mempty

instance showMaterial :: Show Material where
    show Wood       = "wooden"
    show Leather    = "leather"
    show Copper     = "copper"
    show Iron       = "iron"
    show Steel      = "steel"
    show Titanium   = "titanium"
    show Adamantine = "adamantine"

--------- WEAPON AND ARMOR PREFIXES ---------

data WeaponPrefix = Broken | Rusty | Dull | Sharp | Lethal | Masterwork | Light | Balanced | Heavy | Godly

data ArmorPrefix = BrokenA | RustyA | MasterworkA | LightA | HeavyA | GodlyA

prefixStatWeapon :: WeaponPrefix -> WeaponStat
prefixStatWeapon Broken     = WeaponStat { damage: -3, weight: -1, attackSpeed:   50, attackBonus: -4 }
prefixStatWeapon Rusty      = WeaponStat { damage: -2, weight:  1, attackSpeed:    0, attackBonus: -2 }
prefixStatWeapon Dull       = WeaponStat { damage: -1, weight:  0, attackSpeed:    0, attackBonus: -1 }
prefixStatWeapon Sharp      = WeaponStat { damage:  1, weight:  0, attackSpeed:    0, attackBonus:  1 }
prefixStatWeapon Lethal     = WeaponStat { damage:  2, weight:  0, attackSpeed:    0, attackBonus:  2 }
prefixStatWeapon Masterwork = WeaponStat { damage:  3, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Godly      = WeaponStat { damage:  4, weight:  0, attackSpeed: -200, attackBonus:  4 }
prefixStatWeapon Light      = WeaponStat { damage:  0, weight: -2, attackSpeed: -100, attackBonus:  1 }
prefixStatWeapon Balanced   = WeaponStat { damage:  1, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Heavy      = WeaponStat { damage:  2, weight:  3, attackSpeed:  100, attackBonus:  0 }
prefixStatWeapon _          = mempty

prefixStatArmor :: ArmorPrefix -> ArmorStat
prefixStatArmor BrokenA     = ArmorStat { defence: -1, weight:  -5 }
prefixStatArmor RustyA      = ArmorStat { defence:  1, weight:   5 }
prefixStatArmor MasterworkA = ArmorStat { defence:  5, weight:   5 }
prefixStatArmor GodlyA      = ArmorStat { defence:  7, weight:  10 }
prefixStatArmor LightA      = ArmorStat { defence:  0, weight: -10 }
prefixStatArmor HeavyA      = ArmorStat { defence:  2, weight:  10 }
prefixStatArmor _          = mempty

showPrefixWeapon :: [WeaponPrefix] -> String
showPrefixWeapon = joinWith " " <<< map show

instance showWeaponPrefix :: Show WeaponPrefix where
    show Rusty      = "rusty"
    show Broken     = "broken"
    show Dull       = "dull"
    show Masterwork = "masterwork"
    show Sharp      = "sharp"
    show Lethal     = "lethal"
    show Light      = "light"
    show Balanced   = "balanced"
    show Heavy      = "heavy"
    show Godly      = "godly"

showPrefixArmor :: [ArmorPrefix] -> String
showPrefixArmor = joinWith " " <<< map show

instance showArmorPrefix :: Show ArmorPrefix where
    show RustyA      = "rusty"
    show BrokenA     = "broken"
    show MasterworkA = "masterwork"
    show LightA      = "light"
    show HeavyA      = "heavy"
    show GodlyA      = "godly"

--------- WEAPON TYPES ---------

data WeaponType = Sword | Axe | Dagger | Spear | Mace | BattleAxe

instance showWeaponType :: Show WeaponType where
    show Sword     = "sword"
    show Axe       = "axe"
    show Dagger    = "dagger"
    show Spear     = "spear"
    show Mace      = "mace"
    show BattleAxe = "battleaxe"

weaponTypeStat :: WeaponType -> WeaponStat
weaponTypeStat Sword     = WeaponStat { damage: 3, weight:  6, attackSpeed:  800, attackBonus: 1 }
weaponTypeStat Axe       = WeaponStat { damage: 5, weight:  8, attackSpeed: 1200, attackBonus: 0 }
weaponTypeStat Dagger    = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat Spear     = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat Mace      = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat BattleAxe = WeaponStat { damage: 9, weight: 10, attackSpeed: 2000, attackBonus: 2 }

--------- ITEM TYPES ---------

data ItemType = Loot   { value :: Number }
              | Weapon { weaponType :: WeaponType, material :: Material, prefix :: [WeaponPrefix] }
              | Armor  { material :: Material, prefix :: [ArmorPrefix]}
              | Shield { material :: Material, prefix :: [ArmorPrefix] }
              | Ring

instance showItemType :: Show ItemType where
    show (Loot   { value = val })                          = "an item worth of " ++ show val ++ " gold coins"
    show (Weapon { weaponType = t, material = mat, prefix  = [] })         = show t
    show (Weapon { weaponType = t, material = mat, prefix  = prefixList }) = showPrefixWeapon prefixList ++ " " ++ show mat ++ " " ++ show t
    show (Armor  { material = mat, prefix = [] })          = show mat ++ " armor"
    show (Armor  { material = mat, prefix = prefixList })  = showPrefixArmor prefixList ++ " " ++ show mat ++ " armor"
    show (Shield  { material = mat, prefix = [] })         = show mat ++ " shield"
    show (Shield  { material = mat, prefix = prefixList }) = showPrefixArmor prefixList ++ " " ++ show mat ++ " shield"
    show Ring                                              = "One ring to fold them and in Haskell bind them."
    show _                                                 = "unknown item"

--------- ITEM ---------

type Item = { itemType :: ItemType, pos :: Point, vel :: Point }

carryingWeight :: [Item] -> Number
carryingWeight [] = 0
carryingWeight (x:xs) =
  case x.itemType of
    Weapon w -> (weaponStat x).weight + (carryingWeight xs)
    Armor  w -> (armorStat  x).weight + (carryingWeight xs)
    Shield w -> (armorStat  x).weight + (carryingWeight xs)
    _        -> carryingWeight xs

weaponStat :: Item -> WeaponStatRecord
weaponStat { itemType = Weapon w } = extractStatWeapon (materialStatWeapon w.material <> weaponTypeStat w.weaponType <> (monoidSum <<< map prefixStatWeapon $ w.prefix))
weaponStat _ = extractStatWeapon mempty

armorStat :: Item -> ArmorStatRecord
armorStat { itemType = Armor  w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat { itemType = Shield w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat _ = extractStatArmor mempty

showItem :: Item -> String
showItem i@{ itemType = Weapon _ } = let s = weaponStat i in show i.itemType ++ ", Dmg: "     ++ show (s.damage)  ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Armor  _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Shield _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i = show i.itemType

module GameData where

import Data.Tuple
import Data.Array (map)
import Data.String
import Data.Monoid
import Data.Foldable
import qualified Data.Map as M
import Utils
import Math

type Point = { x :: Number, y :: Number }

(.+.) :: Point -> Point -> Point
(.+.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1+x2, y: y1+y2}
infixl 9 .+.

(.-.) :: Point -> Point -> Point
(.-.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1-x2, y: y1-y2}
infixl 9 .-.

(.==.) :: Point -> Point -> Boolean
(.==.) {x = x1, y = y1} {x = x2, y = y2} = x1 == x2 && y1 == y2

showPoint :: Point -> String
showPoint p = "(" ++ show p.x ++ ", " ++ show p.y ++ ")"

manhattanDistance :: Point -> Point -> Number
manhattanDistance {x = x1, y = y1} {x = x2, y=y2} = abs (x1 - x2) + abs (y1 - y2)

distanceSq :: Point -> Point -> Number
distanceSq {x = x1, y = y1} {x = x2, y=y2} = (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

zerop :: Point
zerop = {x: 0, y: 0}

unitp :: Point -> Point
unitp p = {x: sign p.x, y: sign p.y}

type Stats =
    { maxHp :: Number
    , hp    :: Number
    , str   :: Number
    , dex   :: Number
    , int   :: Number
    }

defaultStats :: Stats
defaultStats = { maxHp: 10, hp: 10, str: 10, dex: 10, int: 10 }

guardStats :: Stats
guardStats = { maxHp: 20, hp: 20, str: 8, dex: 8, int: 10 }

archerStats :: Stats
archerStats = { maxHp: 10, hp: 10, str: 6, dex: 10, int: 10 }

statsToString :: Stats -> String
statsToString { maxHp = mh, hp  = h, str = s, dex = d, int = i } = "Hp: " ++ show h ++ "/" ++ show mh ++ ". Str: " ++ show s ++ ". Dex: " ++ show d ++ ". Int: " ++ show i ++"."
statsToString _ = ""

statModf :: Number -> Number
statModf x = -5 + floor (x / 2)

data SkillType = WeaponSkill | Sneak | Athletics | Lockpick

type Skill = { level :: Number, prog :: Number }

type Skills = M.Map SkillType Skill

instance showSkillType :: Show SkillType where
    show WeaponSkill = "weapon"
    show Sneak       = "sneaking"
    show Athletics   = "athletics"
    show Lockpick    = "lockpicking"

instance ordSkillType :: Ord SkillType where
    compare a b = compare (show a) (show b)

instance eqSkillType :: Eq SkillType where
    (==) a b = show a == show b
    (/=) a b = not (a == b)

defaultSkills :: Skills
defaultSkills = M.fromList [Tuple WeaponSkill {level: 0, prog: 0}
                           ,Tuple Sneak { level: 0, prog: 0}
                           ,Tuple Athletics { level: 0, prog: 0}
                           ,Tuple Lockpick { level: 0, prog: 0}
                           ]

startingClass :: [String]
startingClass = ["the knight", "the monk", "the ninja", "the peasant", "the rogue", "the scholar", "the skillmaster", "the soldier", "the developer"]

startingStats :: [Stats]
startingStats = [ { maxHp: 10, hp: 10, str: 14, dex:  9, int: 10 } -- Knight
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 12 } -- Monk
                , { maxHp: 10, hp: 10, str:  9, dex: 14, int: 10 } -- Ninja
                , { maxHp:  9, hp:  9, str:  9, dex:  9, int:  9 } -- Peasant
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 11 } -- Rogue
                , { maxHp: 10, hp: 10, str: 09, dex: 11, int: 13 } -- Scholar
                , { maxHp: 10, hp: 10, str: 10, dex: 10, int: 11 } -- Skillmaster
                , { maxHp: 10, hp: 10, str: 12, dex: 11, int: 10 } -- Soldier
                , { maxHp: 99, hp: 99, str: 99, dex: 99, int: 99 } -- Developer
                ]

startingSkillpoints :: [Number]
startingSkillpoints = [ 2 -- Knight
                      , 2 -- Monk
                      , 2 -- Ninja
                      , 1 -- Peasant
                      , 5 -- Rogue
                      , 5 -- Scholar
                      , 8 -- Skillmaster
                      , 2 -- Soldier
                      , 99 -- Developer
                      ]

skillsInfo :: Skills -> String
skillsInfo skills = skillsToString $ M.toList skills
    where
        skillToString :: Tuple SkillType Skill -> String
        skillToString (Tuple sType { level = l, prog = p }) = fill (show sType ++ " skill. ") 21 ++ fill (" Level: " ++ show l ++ ".") 11 ++ " Progress (0 - " ++ show (100 + l * 50) ++ "): " ++ show p ++"\n"

        skillsToString :: [Tuple SkillType Skill] -> String
        skillsToString [] = ""
        skillsToString (x:xs) = skillToString x ++ ("\n") ++ skillsToString xs

data CreatureType = Player | Guard | Archer | Peasant

instance showCT :: Show CreatureType where
    show Player  = "player"
    show Guard   = "guard"
    show Archer  = "archer"
    show Peasant = "peasant"

instance eqCT :: Eq CreatureType where
    (==) a b = show a == show b
    (/=) a b = show a /= show b

data AIState = Sleep
             | Idle Point   -- idling position
             | Patrol Point -- where to go

data Alertness = NoAlert  -- Does not see player
               | MightSee -- There is LOS and a chance to turn into Suspicious
               | Suspicious Number -- Number = progress towards alert
               | Alert Number -- Number = number of turns to stay alert

data AI = AI Alertness AIState | NoAI

type Creature =
    { pos   :: Point -- Position
    , dir   :: Point -- Facing direction
    , ctype :: CreatureType
    , stats :: Stats
    , time  :: Number
    , vel   :: Point -- Velocity
    , ai    :: AI
    }

--------- ARMOR STAT ---------

type ArmorStatRecord = { defence :: Number, weight :: Number }

data ArmorStat = ArmorStat ArmorStatRecord

extractStatArmor :: ArmorStat -> ArmorStatRecord
extractStatArmor (ArmorStat s) = s

instance semigroupArmorStat :: Semigroup ArmorStat where
    (<>) (ArmorStat a) (ArmorStat b) =
        ArmorStat { defence: a.defence + b.defence
                  , weight: a.weight + b.weight
                  }

instance monoidArmorStat :: Monoid ArmorStat where
    mempty = ArmorStat { defence: 0, weight: 0 }

--------- WEAPON STAT ---------

type WeaponStatRecord = { damage :: Number, weight :: Number, attackSpeed :: Number, attackBonus :: Number }

data WeaponStat = WeaponStat WeaponStatRecord

extractStatWeapon :: WeaponStat -> WeaponStatRecord
extractStatWeapon (WeaponStat s) = s

instance semigroupWeaponStat :: Semigroup WeaponStat where
    (<>) (WeaponStat a) (WeaponStat b) =
        WeaponStat { damage: a.damage + b.damage
                   , weight: a.weight + b.weight
                   , attackSpeed: a.attackSpeed + b.attackSpeed
                   , attackBonus: a.attackBonus + b.attackBonus
                   }

instance monoidWeaponStat :: Monoid WeaponStat where
    mempty = WeaponStat { damage: 0, weight: 0, attackSpeed: 0, attackBonus: 0 }

--------- MATERIALS ---------

data Material = Wood | Copper | Iron | Steel | Titanium | Adamantine | Leather

materialStatWeapon :: Material -> WeaponStat
materialStatWeapon Wood       = WeaponStat { damage: -3, weight: -1, attackSpeed:  -50, attackBonus: 4 }
materialStatWeapon Copper     = WeaponStat { damage: -1, weight:  1, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Iron       = WeaponStat { damage:  0, weight:  2, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Steel      = WeaponStat { damage:  1, weight:  3, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Titanium   = WeaponStat { damage:  2, weight:  4, attackSpeed:    0, attackBonus: 0 }
materialStatWeapon Adamantine = WeaponStat { damage:  3, weight:  4, attackSpeed: -100, attackBonus: 1 }
materialStatWeapon _ = mempty

materialStatArmor :: Material -> ArmorStat
materialStatArmor Leather    = ArmorStat { defence: 1, weight: 10 }
materialStatArmor Copper     = ArmorStat { defence: 2, weight: 30 }
materialStatArmor Iron       = ArmorStat { defence: 3, weight: 35 }
materialStatArmor Steel      = ArmorStat { defence: 4, weight: 45 }
materialStatArmor Titanium   = ArmorStat { defence: 5, weight: 60 }
materialStatArmor Adamantine = ArmorStat { defence: 7, weight: 60 }
materialStatArmor _ = mempty

instance showMaterial :: Show Material where
    show Wood       = "wooden"
    show Leather    = "leather"
    show Copper     = "copper"
    show Iron       = "iron"
    show Steel      = "steel"
    show Titanium   = "titanium"
    show Adamantine = "adamantine"

--------- WEAPON AND ARMOR PREFIXES ---------

data WeaponPrefix = Broken | Rusty | Dull | Sharp | Lethal | Masterwork | Light | Balanced | Heavy | Godly

data ArmorPrefix = BrokenA | RustyA | MasterworkA | LightA | HeavyA | GodlyA

prefixStatWeapon :: WeaponPrefix -> WeaponStat
prefixStatWeapon Broken     = WeaponStat { damage: -3, weight: -1, attackSpeed:   50, attackBonus: -4 }
prefixStatWeapon Rusty      = WeaponStat { damage: -2, weight:  1, attackSpeed:    0, attackBonus: -2 }
prefixStatWeapon Dull       = WeaponStat { damage: -1, weight:  0, attackSpeed:    0, attackBonus: -1 }
prefixStatWeapon Sharp      = WeaponStat { damage:  1, weight:  0, attackSpeed:    0, attackBonus:  1 }
prefixStatWeapon Lethal     = WeaponStat { damage:  2, weight:  0, attackSpeed:    0, attackBonus:  2 }
prefixStatWeapon Masterwork = WeaponStat { damage:  3, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Godly      = WeaponStat { damage:  4, weight:  0, attackSpeed: -200, attackBonus:  4 }
prefixStatWeapon Light      = WeaponStat { damage:  0, weight: -2, attackSpeed: -100, attackBonus:  1 }
prefixStatWeapon Balanced   = WeaponStat { damage:  1, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Heavy      = WeaponStat { damage:  2, weight:  3, attackSpeed:  100, attackBonus:  0 }
prefixStatWeapon _          = mempty

prefixStatArmor :: ArmorPrefix -> ArmorStat
prefixStatArmor BrokenA     = ArmorStat { defence: -1, weight:  -5 }
prefixStatArmor RustyA      = ArmorStat { defence:  1, weight:   5 }
prefixStatArmor MasterworkA = ArmorStat { defence:  5, weight:   5 }
prefixStatArmor GodlyA      = ArmorStat { defence:  7, weight:  10 }
prefixStatArmor LightA      = ArmorStat { defence:  0, weight: -10 }
prefixStatArmor HeavyA      = ArmorStat { defence:  2, weight:  10 }
prefixStatArmor _          = mempty

showPrefixWeapon :: [WeaponPrefix] -> String
showPrefixWeapon = joinWith " " <<< map show

instance showWeaponPrefix :: Show WeaponPrefix where
    show Rusty      = "rusty"
    show Broken     = "broken"
    show Dull       = "dull"
    show Masterwork = "masterwork"
    show Sharp      = "sharp"
    show Lethal     = "lethal"
    show Light      = "light"
    show Balanced   = "balanced"
    show Heavy      = "heavy"
    show Godly      = "godly"

showPrefixArmor :: [ArmorPrefix] -> String
showPrefixArmor = joinWith " " <<< map show

instance showArmorPrefix :: Show ArmorPrefix where
    show RustyA      = "rusty"
    show BrokenA     = "broken"
    show MasterworkA = "masterwork"
    show LightA      = "light"
    show HeavyA      = "heavy"
    show GodlyA      = "godly"

--------- WEAPON TYPES ---------

data WeaponType = Sword | Axe | Dagger | Spear | Mace | BattleAxe

instance showWeaponType :: Show WeaponType where
    show Sword     = "sword"
    show Axe       = "axe"
    show Dagger    = "dagger"
    show Spear     = "spear"'
    show Mace      = "mace"
    show BattleAxe = "battleaxe"

weaponTypeStat :: WeaponType -> WeaponStat
weaponTypeStat Sword     = WeaponStat { damage: 3, weight:  6, attackSpeed:  800, attackBonus: 1 }
weaponTypeStat Axe       = WeaponStat { damage: 5, weight:  8, attackSpeed: 1200, attackBonus: 0 }
weaponTypeStat Dagger    = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat Spear     = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat Mace      = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat BattleAxe = WeaponStat { damage: 9, weight: 10, attackSpeed: 2000, attackBonus: 2 }

--------- ITEM TYPES ---------

data ItemType = Loot   { value :: Number }
              | Weapon { weaponType :: WeaponType, material :: Material, prefix :: [WeaponPrefix] }
              | Armor  { material :: Material, prefix :: [ArmorPrefix]}
              | Shield { material :: Material, prefix :: [ArmorPrefix] }
              | Ring

instance showItemType :: Show ItemType where
    show (Loot   { value = val })                          = "an item worth of " ++ show val ++ " gold coins"
    show (Weapon { weaponType = t, material = mat, prefix  = [] })         = show t
    show (Weapon { weaponType = t, material = mat, prefix  = prefixList }) = showPrefixWeapon prefixList ++ " " ++ show mat ++ " " ++ show t
    show (Armor  { material = mat, prefix = [] })          = show mat ++ " armor"
    show (Armor  { material = mat, prefix = prefixList })  = showPrefixArmor prefixList ++ " " ++ show mat ++ " armor"
    show (Shield  { material = mat, prefix = [] })         = show mat ++ " shield"
    show (Shield  { material = mat, prefix = prefixList }) = showPrefixArmor prefixList ++ " " ++ show mat ++ " shield"
    show Ring                                              = "One ring to fold them and in Haskell bind them."
    show _                                                 = "unknown item"

--------- ITEM ---------

type Item = { itemType :: ItemType, pos :: Point, vel :: Point }

carryingWeight :: [Item] -> Number
carryingWeight [] = 0
carryingWeight (x:xs) =
  case x.itemType of
    Weapon w -> (weaponStat x).weight + (carryingWeight xs)
    Armor  w -> (armorStat  x).weight + (carryingWeight xs)
    Shield w -> (armorStat  x).weight + (carryingWeight xs)
    _        -> carryingWeight xs

weaponStat :: Item -> WeaponStatRecord
weaponStat { itemType = Weapon w } = extractStatWeapon (materialStatWeapon w.material <> weaponTypeStat w.weaponType <> (monoidSum <<< map prefixStatWeapon $ w.prefix))
weaponStat _ = extractStatWeapon mempty

armorStat :: Item -> ArmorStatRecord
armorStat { itemType = Armor  w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat { itemType = Shield w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat _ = extractStatArmor mempty

showItem :: Item -> String
showItem i@{ itemType = Weapon _ } = let s = weaponStat i in show i.itemType ++ ", Dmg: "     ++ show (s.damage)  ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Armor  _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Shield _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i = show i.itemType


tweaked upgrade costs

tweaked upgrade costs

module Upgrades
  ( upgradeCost
  , upgradeName
  , nextUpgrade
  , canBuyUpgrade
  , upgradeDescription
  , buyUpgrade
  , isInflectionUpgrade
  , inflectionUpgradeMessage
  , cpsFromUpgrades
  , burstFromUpgrades
  ) where

import Prelude
import Data.Foldable (elem, sum, foldl)
import Data.Array (concat)
import Data.Int (toNumber)
import Data.Lens (LensP(), (^.), (+~), (-~), (.~), view)

import Types
import Lenses
import Util

upgradeCost :: Upgrade -> Clicks
upgradeCost (Misc1 n)    = Clicks (upgradeCostPolynomial 10.0 n)
upgradeCost (Misc2 n)    = Clicks (upgradeCostPolynomial 500.0 n)
upgradeCost (Tech1 n)    = Clicks (upgradeCostPolynomial 7500.0 n)
upgradeCost (Tech2 n)    = Clicks (upgradeCostPolynomial 950000.0 n)
upgradeCost (Phil1 n)    = Clicks (upgradeCostPolynomial 8250000.0 n)
upgradeCost (Phil2 n)    = Clicks (upgradeCostPolynomial 52000000.0 n)
upgradeCost (Poli1 n)    = Clicks (upgradeCostPolynomial 800000000.0 n)
upgradeCost (Poli2 n)    = Clicks (upgradeCostPolynomial 6050000000.0 n)
upgradeCost (Science1 n) = Clicks (upgradeCostPolynomial 60050000400.0 n)
upgradeCost (Science2 n) = Clicks (upgradeCostPolynomial 650000700000.0 n)

upgradeCostPolynomial :: Number -> Int -> Number
upgradeCostPolynomial coeff level = upgradeCostModifier level * coeff * 1.2 ^ (toNumber level)

upgradeCostModifier :: Int -> Number
upgradeCostModifier n
  | n <= 10 = 1.5
  | n <= 25 = 1.0
  | n <= 50 = 0.75
  | n <= 75 = 0.5
  | n <= 100 = 0.25
  | otherwise = 0.125

upgradeName :: Upgrade -> Age -> String
upgradeName (Misc1 _) Stone = "language"
upgradeName (Misc2 _) Stone = "spear tips"
upgradeName (Tech1 _) Stone = "fire!"
upgradeName (Tech2 _) Stone = "stone tools"
upgradeName (Phil1 _) Stone = "funeral rites"
upgradeName (Phil2 _) Stone = "cave paintings"
upgradeName (Poli1 _) Stone = "basic fishing"
upgradeName (Poli2 _) Stone = "rudimentary farming"
upgradeName (Science1 _) Stone = "dog domestication"
upgradeName (Science2 _) Stone = "abstract numbers"

upgradeDescription :: Upgrade -> Age -> String
upgradeDescription (Misc1 _) Stone = "No more grunt-and-point for you!"
upgradeDescription (Misc2 _) Stone = "Tip: a well-balanced spear is crucial for hunting."
upgradeDescription (Tech1 _) Stone = "We DID start the fire."
upgradeDescription (Tech2 _) Stone = "Never leave the Stone Age without 'em."
upgradeDescription (Phil1 _) Stone = "Funerals are a basic human rite."
upgradeDescription (Phil2 _) Stone = "You're no Picasso, but your paintings will last longer."
upgradeDescription (Poli1 _) Stone = "Fishing for landsharks?"
upgradeDescription (Poli2 _) Stone = "Can I interest you in some delicious BEETS?"
upgradeDescription (Science1 _) Stone = "A Clickonian's best friend."
upgradeDescription (Science2 _) Stone = "You've discovered that two clicks and two dogs both share 'twoness.' You also almost discovered the ultrafilter lemma, but you couldn't write it down fast enough. Because you haven't discovered writing yet."

nextUpgrade :: Upgrade -> Upgrade
nextUpgrade (Misc1 n) = Misc1 (n + 1)
nextUpgrade (Misc2 n) = Misc2 (n + 1)
nextUpgrade (Tech1 n) = Tech1 (n + 1)
nextUpgrade (Tech2 n) = Tech2 (n + 1)
nextUpgrade (Phil1 n) = Phil1 (n + 1)
nextUpgrade (Phil2 n) = Phil2 (n + 1)
nextUpgrade (Poli1 n) = Poli1 (n + 1)
nextUpgrade (Poli2 n) = Poli2 (n + 1)
nextUpgrade (Science1 n) = Science1 (n + 1)
nextUpgrade (Science2 n) = Science2 (n + 1)

canBuyUpgrade :: State -> LensP Upgrades Upgrade -> Boolean
canBuyUpgrade state optic =
  let currClicks = state ^. currentClicks
      currUpgrade = state ^. upgrades <<< optic
      next = nextUpgrade currUpgrade
      nextCost = upgradeCost next
   in currClicks >= nextCost

upgradeBoost :: Upgrade -> Number
upgradeBoost (Misc1 n)    = 0.5 * upgradeBoostModifier n
upgradeBoost (Misc2 n)    = 4.0 * upgradeBoostModifier n
upgradeBoost (Tech1 n)    = 30.0 * upgradeBoostModifier n
upgradeBoost (Tech2 n)    = 400.0 * upgradeBoostModifier n
upgradeBoost (Phil1 n)    = 6000.0 * upgradeBoostModifier n
upgradeBoost (Phil2 n)    = 12220.5 * upgradeBoostModifier n
upgradeBoost (Poli1 n)    = 214592.6 * upgradeBoostModifier n
upgradeBoost (Poli2 n)    = 1712818.2 * upgradeBoostModifier n
upgradeBoost (Science1 n) = 49000000.0 * upgradeBoostModifier n
upgradeBoost (Science2 n) = 100000000.0 * upgradeBoostModifier n

upgradeBoostModifier :: Int -> Number
upgradeBoostModifier n
  | n <= 10 = 1.0
  | n <= 25 = 4.0
  | n <= 50 = 16.0
  | n <= 75 = 64.0
  | n <= 100 = 256.0
  | otherwise = 1024.0

buyUpgrade :: Upgrade -> State -> State
buyUpgrade up@(Misc1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc1
buyUpgrade up@(Misc2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc2
buyUpgrade up@(Tech1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech1
buyUpgrade up@(Tech2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech2
buyUpgrade up@(Phil1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil1
buyUpgrade up@(Phil2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil2
buyUpgrade up@(Poli1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli1
buyUpgrade up@(Poli2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli2
buyUpgrade up@(Science1 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science1
buyUpgrade up@(Science2 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science2

recordPurchase :: Upgrade -> LensP Upgrades Upgrade -> State -> State
recordPurchase up optic = (currentClicks -~ upgradeCost up)
                      <<< (upgrades <<< optic .~ up)

installUpgrade :: Upgrade -> LensP State Number -> Number -> State -> State
installUpgrade up optic coeff = optic +~ coeff * upgradeBoost up

isInflectionUpgrade :: Upgrade -> Boolean
isInflectionUpgrade up = (up ^. viewLevel) `elem` [10, 25, 50, 75, 100]

inflectionUpgradeMessage :: Upgrade -> Age -> String
inflectionUpgradeMessage up age = upgradeName up age ++ " cost down, boost up"

makeUpgradedState :: Upgrades -> State
makeUpgradedState u = foldl (flip buyUpgrade) initialState upArray
  where
    upArray = concat [ misc1arr, misc2arr, tech1arr, tech2arr, phil1arr
                     , phil2arr, poli1arr, poli2arr, science1arr, science2arr ]
    misc1arr    = Misc1 <$> 1 ... u ^. misc1 <<< viewLevel
    misc2arr    = Misc2 <$> 1 ... u ^. misc2 <<< viewLevel
    tech1arr    = Tech1 <$> 1 ... u ^. tech1 <<< viewLevel
    tech2arr    = Tech2 <$> 1 ... u ^. tech2 <<< viewLevel
    phil1arr    = Phil1 <$> 1 ... u ^. phil1 <<< viewLevel
    phil2arr    = Phil2 <$> 1 ... u ^. phil2 <<< viewLevel
    poli1arr    = Poli1 <$> 1 ... u ^. poli1 <<< viewLevel
    poli2arr    = Poli2 <$> 1 ... u ^. poli2 <<< viewLevel
    science1arr = Science1 <$> 1 ... u ^. science1 <<< viewLevel
    science2arr = Science2 <$> 1 ... u ^. science2 <<< viewLevel

cpsFromUpgrades :: Upgrades -> ClicksPerSecond
cpsFromUpgrades = view cps <<< makeUpgradedState

burstFromUpgrades :: Upgrades -> Clicks
burstFromUpgrades = view burst <<< makeUpgradedState

module Upgrades
  ( upgradeCost
  , upgradeName
  , nextUpgrade
  , canBuyUpgrade
  , upgradeDescription
  , buyUpgrade
  , isInflectionUpgrade
  , inflectionUpgradeMessage
  , cpsFromUpgrades
  , burstFromUpgrades
  ) where

import Prelude
import Data.Foldable (elem, sum, foldl)
import Data.Array (concat)
import Data.Int (toNumber)
import Data.Lens (LensP(), (^.), (+~), (-~), (.~), view)

import Types
import Lenses
import Util

upgradeCost :: Upgrade -> Clicks
upgradeCost (Misc1 n)    = Clicks (upgradeCostPolynomial 10.0 n)
upgradeCost (Misc2 n)    = Clicks (upgradeCostPolynomial 500.0 n)
upgradeCost (Tech1 n)    = Clicks (upgradeCostPolynomial 7500.0 n)
upgradeCost (Tech2 n)    = Clicks (upgradeCostPolynomial 950000.0 n)
upgradeCost (Phil1 n)    = Clicks (upgradeCostPolynomial 8250000.0 n)
upgradeCost (Phil2 n)    = Clicks (upgradeCostPolynomial 52000000.0 n)
upgradeCost (Poli1 n)    = Clicks (upgradeCostPolynomial 800000000.0 n)
upgradeCost (Poli2 n)    = Clicks (upgradeCostPolynomial 6050000000.0 n)
upgradeCost (Science1 n) = Clicks (upgradeCostPolynomial 600500004000.0 n)
upgradeCost (Science2 n) = Clicks (upgradeCostPolynomial 6500007000080.0 n)

upgradeCostPolynomial :: Number -> Int -> Number
upgradeCostPolynomial coeff level = upgradeCostModifier level * coeff * 1.2 ^ (toNumber level)

upgradeCostModifier :: Int -> Number
upgradeCostModifier n
  | n <= 10 = 1.5
  | n <= 25 = 1.0
  | n <= 50 = 0.75
  | n <= 75 = 0.5
  | n <= 100 = 0.25
  | otherwise = 0.125

upgradeName :: Upgrade -> Age -> String
upgradeName (Misc1 _) Stone = "language"
upgradeName (Misc2 _) Stone = "spear tips"
upgradeName (Tech1 _) Stone = "fire!"
upgradeName (Tech2 _) Stone = "stone tools"
upgradeName (Phil1 _) Stone = "funeral rites"
upgradeName (Phil2 _) Stone = "cave paintings"
upgradeName (Poli1 _) Stone = "basic fishing"
upgradeName (Poli2 _) Stone = "rudimentary farming"
upgradeName (Science1 _) Stone = "dog domestication"
upgradeName (Science2 _) Stone = "abstract numbers"

upgradeDescription :: Upgrade -> Age -> String
upgradeDescription (Misc1 _) Stone = "No more grunt-and-point for you!"
upgradeDescription (Misc2 _) Stone = "Tip: a well-balanced spear is crucial for hunting."
upgradeDescription (Tech1 _) Stone = "We DID start the fire."
upgradeDescription (Tech2 _) Stone = "Never leave the Stone Age without 'em."
upgradeDescription (Phil1 _) Stone = "Funerals are a basic human rite."
upgradeDescription (Phil2 _) Stone = "You're no Picasso, but your paintings will last longer."
upgradeDescription (Poli1 _) Stone = "Fishing for landsharks?"
upgradeDescription (Poli2 _) Stone = "Can I interest you in some delicious BEETS?"
upgradeDescription (Science1 _) Stone = "A Clickonian's best friend."
upgradeDescription (Science2 _) Stone = "You've discovered that two clicks and two dogs both share 'twoness.' You also almost discovered the ultrafilter lemma, but you couldn't write it down fast enough. Because you haven't discovered writing yet."

nextUpgrade :: Upgrade -> Upgrade
nextUpgrade (Misc1 n) = Misc1 (n + 1)
nextUpgrade (Misc2 n) = Misc2 (n + 1)
nextUpgrade (Tech1 n) = Tech1 (n + 1)
nextUpgrade (Tech2 n) = Tech2 (n + 1)
nextUpgrade (Phil1 n) = Phil1 (n + 1)
nextUpgrade (Phil2 n) = Phil2 (n + 1)
nextUpgrade (Poli1 n) = Poli1 (n + 1)
nextUpgrade (Poli2 n) = Poli2 (n + 1)
nextUpgrade (Science1 n) = Science1 (n + 1)
nextUpgrade (Science2 n) = Science2 (n + 1)

canBuyUpgrade :: State -> LensP Upgrades Upgrade -> Boolean
canBuyUpgrade state optic =
  let currClicks = state ^. currentClicks
      currUpgrade = state ^. upgrades <<< optic
      next = nextUpgrade currUpgrade
      nextCost = upgradeCost next
   in currClicks >= nextCost

upgradeBoost :: Upgrade -> Number
upgradeBoost (Misc1 n)    = 0.5 * upgradeBoostModifier n
upgradeBoost (Misc2 n)    = 4.0 * upgradeBoostModifier n
upgradeBoost (Tech1 n)    = 30.0 * upgradeBoostModifier n
upgradeBoost (Tech2 n)    = 400.0 * upgradeBoostModifier n
upgradeBoost (Phil1 n)    = 6000.0 * upgradeBoostModifier n
upgradeBoost (Phil2 n)    = 12220.5 * upgradeBoostModifier n
upgradeBoost (Poli1 n)    = 214592.6 * upgradeBoostModifier n
upgradeBoost (Poli2 n)    = 1712818.2 * upgradeBoostModifier n
upgradeBoost (Science1 n) = 49000000.0 * upgradeBoostModifier n
upgradeBoost (Science2 n) = 100000000.0 * upgradeBoostModifier n

upgradeBoostModifier :: Int -> Number
upgradeBoostModifier n
  | n <= 10 = 1.0
  | n <= 25 = 4.0
  | n <= 50 = 16.0
  | n <= 75 = 64.0
  | n <= 100 = 256.0
  | otherwise = 1024.0

buyUpgrade :: Upgrade -> State -> State
buyUpgrade up@(Misc1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc1
buyUpgrade up@(Misc2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc2
buyUpgrade up@(Tech1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech1
buyUpgrade up@(Tech2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech2
buyUpgrade up@(Phil1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil1
buyUpgrade up@(Phil2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil2
buyUpgrade up@(Poli1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli1
buyUpgrade up@(Poli2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli2
buyUpgrade up@(Science1 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science1
buyUpgrade up@(Science2 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science2

recordPurchase :: Upgrade -> LensP Upgrades Upgrade -> State -> State
recordPurchase up optic = (currentClicks -~ upgradeCost up)
                      <<< (upgrades <<< optic .~ up)

installUpgrade :: Upgrade -> LensP State Number -> Number -> State -> State
installUpgrade up optic coeff = optic +~ coeff * upgradeBoost up

isInflectionUpgrade :: Upgrade -> Boolean
isInflectionUpgrade up = (up ^. viewLevel) `elem` [10, 25, 50, 75, 100]

inflectionUpgradeMessage :: Upgrade -> Age -> String
inflectionUpgradeMessage up age = upgradeName up age ++ " cost down, boost up"

makeUpgradedState :: Upgrades -> State
makeUpgradedState u = foldl (flip buyUpgrade) initialState upArray
  where
    upArray = concat [ misc1arr, misc2arr, tech1arr, tech2arr, phil1arr
                     , phil2arr, poli1arr, poli2arr, science1arr, science2arr ]
    misc1arr    = Misc1 <$> 1 ... u ^. misc1 <<< viewLevel
    misc2arr    = Misc2 <$> 1 ... u ^. misc2 <<< viewLevel
    tech1arr    = Tech1 <$> 1 ... u ^. tech1 <<< viewLevel
    tech2arr    = Tech2 <$> 1 ... u ^. tech2 <<< viewLevel
    phil1arr    = Phil1 <$> 1 ... u ^. phil1 <<< viewLevel
    phil2arr    = Phil2 <$> 1 ... u ^. phil2 <<< viewLevel
    poli1arr    = Poli1 <$> 1 ... u ^. poli1 <<< viewLevel
    poli2arr    = Poli2 <$> 1 ... u ^. poli2 <<< viewLevel
    science1arr = Science1 <$> 1 ... u ^. science1 <<< viewLevel
    science2arr = Science2 <$> 1 ... u ^. science2 <<< viewLevel

cpsFromUpgrades :: Upgrades -> ClicksPerSecond
cpsFromUpgrades = view cps <<< makeUpgradedState

burstFromUpgrades :: Upgrades -> Clicks
burstFromUpgrades = view burst <<< makeUpgradedState