expedition array

expedition array

module KanColle.Expedition.New.EArray
  ( EArray()
  , mkEA
  , indEA
  ) where

import Prelude
import Partial.Unsafe
import Partial
import Data.Array as A
import Data.Array.Partial as AP

-- array wrappered for all 40 expeditions
newtype EArray a = EA (Array a)

mkEA :: forall a. Array a -> EArray a
mkEA xs
    | A.length xs == 40 = EA xs
    | otherwise = unsafePartial (crash "expecting exactly 40 elements")

indEA :: forall a. EArray a -> Int -> a
indEA (EA xs) i
    | 1 <= i && i <= 40 = unsafePartial (AP.unsafeIndex xs (i-1))
    | otherwise = unsafePartial (crash "index out of range")

error: pathspec 'src/KanColle/Expedition/New/EArray.purs' did not match any file(s) known to git


Fix FFI names

Fix FFI names

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intSub

instance bitsInt :: Bits Int where
  (.&.) (Int x) (Int y) = Int (x .&. y)
  (.|.) (Int x) (Int y) = Int (x .|. y)
  (.^.) (Int x) (Int y) = Int (x .^. y)
  shl (Int x) y = Int (x `shl` y)
  shr (Int x) y = Int (x `shr` y)
  zshr (Int x) y = Int (x `zshr` y)
  complement (Int n) = Int (complement n)

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intMod(x) {
    return function(y) {
      return (x % y + y) % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intSub
  """
  function intSub(x) {
    return function(y) {
      return x - y;
    };
  }
  """ :: Int -> Int -> Int

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intMinus

instance bitsInt :: Bits Int where
  (.&.) (Int x) (Int y) = Int (x .&. y)
  (.|.) (Int x) (Int y) = Int (x .|. y)
  (.^.) (Int x) (Int y) = Int (x .^. y)
  shl (Int x) y = Int (x `shl` y)
  shr (Int x) y = Int (x `shr` y)
  zshr (Int x) y = Int (x `zshr` y)
  complement (Int n) = Int (complement n)

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intDiv(x) {
    return function(y) {
      return (x % y + y) % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMinus
  """
  function intDiv(x) {
    return function(y) {
      return x - y;
    };
  }
  """ :: Int -> Int -> Int


Added Purescript Solution to School Puzzle

module SchoolPuzzle where

import Prelude

-- This is a very simple one, assuming that they stop coming after a lesson (and cannot leave during a lesson)
-- ans = n-1

howManyKidsHadAMark :: Int -> Int
howManyKidsHadAMark numDays = (numDays - 1)

{-
Problem:

There is a school in a far far land. The teacher there teaches whatever he wishes to -- Physics,Maths,Biology, Astronomy, Philosophy, Psychology, English , Hindi and so on. There are 100 students in that school. The school has a uniques set of rules.
1. No student is allowed to question the teacher or ask the teacher anything, they will just listen and follow whatever the teacher has taught them, without questioning him or asking any doubts.
2. No student is allowed to speak to any other student. They just attend attend their classes and then go straight back to their hostel room and lock it from inside and stay there till the next day. They come out of their rooms only to attend their classes and go back as soon as  their class is over.

One night god tells the teacher that he will put a mark on at least one students head indicating that that student has now attained all the knowledge in the world and could now leave the school. The teacher tells this to his students in the class the next day.
God puts a mark on at least one student's head the next day.
However since they cannot speak to each other, therefore other students cannot tell him that there is a mark on his head.
On the 1st day after that, all 100 students come to the class.
On the 2nd day again, all 100 students come to the class.
This goes on till the 23rd day.
On the 24th day however, some students stop coming to the class as they realised that they had a mark on their head.

How many students stopped coming to the class (i.e. had a mark on their head )? -}

error: pathspec 'puzzles/Student_mark/Purescript/school_puzzle.purs' did not match any file(s) known to git


Add Supply

Add Supply

module Language.PureScript.Supply where

import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.State.Trans
import Control.Monad.Error.Class
import Control.Monad.Trans
import Data.Tuple

data SupplyT m a = SupplyT (StateT Number m a)

unSupplyT :: forall m a. SupplyT m a -> StateT Number m a
unSupplyT (SupplyT s) = s

runSupplyT :: forall m a. Number -> SupplyT m a -> m (Tuple a Number)
runSupplyT n = flip runStateT n <<< unSupplyT

evalSupplyT :: forall m a. (Functor m) => Number -> SupplyT m a -> m a
evalSupplyT n = (<$>) fst <<< runSupplyT n

type Supply = SupplyT Identity

runSupply :: forall a. Number -> Supply a -> (Tuple a Number)
runSupply n = runIdentity <<< runSupplyT n

evalSupply :: forall a. Number -> Supply a -> a
evalSupply n = runIdentity <<< evalSupplyT n

fresh :: forall m. (Monad m) => SupplyT m Number
fresh = SupplyT $ do
  n <- get
  put (n + 1)
  return n

freshName :: forall m. (Monad m) => SupplyT m String
freshName = mkName <$> fresh
  where
  mkName n = "_" ++ show n

instance functorSupplyT :: (Monad m) => Functor (SupplyT m) where
  (<$>) f (SupplyT x) = SupplyT (f <$> x)

instance applySupplyT :: (Monad m) => Apply (SupplyT m) where
  (<*>) (SupplyT f) (SupplyT x) = SupplyT (f <*> x)

instance applicativeSupplyT :: (Monad m) => Applicative (SupplyT m) where
  pure a = SupplyT (pure a)

instance bindSupplyT :: (Monad m) => Bind (SupplyT m) where
  (>>=) (SupplyT x) f = SupplyT (x >>= unSupplyT <<< f)

instance monadSupplyT :: (Monad m) => Monad (SupplyT m)

instance monadTransSupplyT :: MonadTrans SupplyT where
  lift = SupplyT <<< lift

instance monadErrorSupplyT :: (Monad m, MonadError e m) => MonadError e (SupplyT m) where
  throwError = SupplyT <<< throwError
  catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT <<< f)

error: pathspec 'src/Language/PureScript/Supply.purs' did not match any file(s) known to git


DI: Automatically infer and annotate dependencies for injection

module Angular.DI (
    Dependency
  , Service
  , RootScope(..)
  , RootElement(..)
  , get
  , Injectable
  , Annotated()
  , annotate
  ) where

import Control.Monad.Eff (Eff())
import Data.Function
import Angular.Injector (Injector(), InjEff())
import Angular.Animate (Animate())
import Angular.Cache (CacheFactory())
import Angular.Http (Http())
import Angular.Interpolate (Interpolate())
import Angular.Interval (Interval())
import Angular.Location (Location())
import Angular.Log (Log())
import Angular.Parse (Parse())
import Angular.Q (Q())
import Angular.Timeout (Timeout())
import Angular.Scope (Scope())
import Angular.Element (Element())
import Angular.Attributes (Attributes())
import Angular.This (This())

-- | A type which can by provided by dependency injection.
class Dependency a where
  name :: String

-- | Services which can be retrieved with get
class (Dependency a) <= Service a

instance dependencyInjector :: Dependency Injector where
  name = "$injector"
instance serviceInjector :: Service Injector

instance dependencyAnimate :: Dependency Animate where
  name = "$animate"
instance serviceAnimate :: Service Animate

instance dependencyCacheFactory :: Dependency CacheFactory where
  name = "$cacheFactory"
instance serviceCacheFactory :: Service CacheFactory

instance dependencyHttp :: Dependency Http where
  name = "$http"
instance serviceHttp :: Service Http

instance dependencyInterpolate :: Dependency Interpolate where
  name = "$interpolate"
instance serviceInterpolate :: Service Interpolate

instance dependencyInterval :: Dependency Interval where
  name = "$interval"
instance serviceInterval :: Service Interval

instance dependencyLocation :: Dependency Location where
  name = "$location"
instance serviceLocation :: Service Location

instance dependencyLog :: Dependency Log where
  name = "$log"
instance serviceLog :: Service Log

instance dependencyParse :: Dependency Parse where
  name = "$parse"
instance serviceParse :: Service Parse

instance dependencyQ :: Dependency Q where
  name = "$q"
instance serviceQ :: Service Q

instance dependencyTimeout :: Dependency Timeout where
  name = "$timeout"
instance serviceTimeout :: Service Timeout

newtype RootScope a = RootScope (Scope a)

instance dependencyRootScope :: Dependency (RootScope a) where
  name = "$rootScope"
instance serviceRootScope :: Service (RootScope a)

instance dependencyScope :: Dependency (Scope a) where
  name = "$scope"

newtype RootElement = RootElement Element

instance dependencyRootElement :: Dependency RootElement where
  name = "$rootElement"
instance serviceRootElement :: Service RootElement

instance dependencyElement :: Dependency Element where
  name = "$element"

instance dependencyAttributes :: Dependency Attributes where
  name = "$attrs"

instance dependencyThis :: Dependency (This a) where
  -- it would be nice to make a dummy service to avoid the special handling
  -- in annotate, but there is nowhere to do so
  name = "$this"

foreign import getDependency
  "function get(dependency) {\
  \ dependency = dependency.name;\
  \ return function ($injector) {\
  \   return function () {\
  \     return $injector.get(dependency);\
  \   };\
  \ };\
  \}" :: forall e a . (Dependency a) => Injector -> InjEff e a

get :: forall e a . (Service a) => Injector -> InjEff e a
get = getDependency

class Injectable a where
  dependencies :: a -> [String]

instance injectableEff :: Injectable (Eff e r) where
  dependencies _ = []

foreign import dependenciesFn
  "function dependenciesFn(dependency) {\
  \ dependency = [dependency.name];\
  \ return function (injectable) {\
  \   return function (/*f*/) {\
  \     return dependency.concat(injectable.dependencies(/*f(a)*/));\
  \   };\
  \ };\
  \}" :: forall a b . (Dependency a, Injectable b) => (a -> b) -> [String]

instance injectableFn :: (Dependency a, Injectable b) => Injectable (a -> b) where
  dependencies f = dependenciesFn f

-- | An Eff function with added dependency injection annotations.
foreign import data Annotated :: * -> *

-- | Infer and annotate a function with its dependencies, that can provided by Injector.invoke or Module functions.
foreign import annotate
  "function annotate(injectable) {\
  \ return function (fun) {\
  \   var inject = injectable.dependencies(fun);\
  \   function g(/*...*/) {\
  \     var f = fun;\
  \     for (var i = 0, a = 0; i < inject.length; i++)\
  \       f = f(inject[i] === '$this' ? this : arguments[a++]);\
  \     return f();\
  \   }\
  \   g.prototype = fun.prototype;\
  \   g.$inject = inject.filter(function (d) { return d !== '$this'; });\
  \   return g;\
  \ };\
  \}" :: forall a . (Injectable a) => a -> Annotated a

error: pathspec 'src/Angular/DI.purs' did not match any file(s) known to git


checkpoint new ifc

checkpoint new ifc

module Model.Presentation.New (
    PresentationError,
    Presentation
) where

import Prelude (($), map, (+), clamp, (-), const, id, (<<<), compose)
import Data.List (List(..), (:), length, (!!))
import Data.Either (Either(..), isRight, either)
import Data.Maybe (Maybe(..), fromJust)
import Partial.Unsafe (unsafePartial)
import Data.NonEmpty (NonEmpty, (:|), fromNonEmpty)
import Optic.Core
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
-- import Content.Slide (slides)

type PresentationError = String

type Content = SlamDown

type PresentationR = {
    index :: Int,
    content :: NonEmpty List SlamDown
}
newtype Presentation = Pr PresentationR

runPresentation :: Presentation -> PresentationR
runPresentation (Pr d) = d

listSize :: forall a. NonEmpty List a -> Int
listSize = fromNonEmpty $ (compose length) <<< Cons

size :: Getter Presentation Int
size = to $ listSize <<< _.content <<< runPresentation

clampIndex :: Presentation -> Int -> Int
clampIndex p = clamp 0 ((p ^. size) - 1)

-- slide :: Lens Presentation Presentation Slide Int
-- slide = lens get' set'
--   where get' (Pr {index: i, content: (c :| cs)}) = Sl {
--                 index: i,
--                 content: unsafePartial $ fromJust $ (c : cs) !! i
--             }
--         set' pr @(Pr p) i = Pr (p { index = clampIndex pr i })

listAt :: forall a. NonEmpty List a -> Int -> a
listAt (c :| cs) i = unsafePartial $ fromJust $ (c : cs) !! i

content :: Getter Presentation Content
content = to get'
  where get' (Pr {index, content}) = listAt content index

-- size :: _
-- size = nonEmptyListSize <<< slides

-- presentationSize :: Presentation -> Int
-- presentationSize = neSize <<< _.slides <<< runPresentation

-- create :: String -> Either PresentationError Presentation
-- create source = case map slides $ parseMd source of
--   Left _ -> Left "parse error"
--   Right Nil -> Left "no content"
--   Right (s : ss) -> Right { index: 0, slides: s :| ss }

-- hydrate :: Int -> SlamDown -> { number :: Int, content :: SlamDown }
-- hydrate index content = { number: index + 1, content }

-- slide :: Presentation -> Slide
-- slide (Left _) = Nothing
-- slide (Right {index: i, slides: (c :| cs)}) = map (hydrate i) (( c : cs) !! i)

-- clampIndex :: Presentation -> Int -> Int
-- clampIndex p = clamp 0 (size p - 1)

-- next :: Presentation -> Presentation
-- next pres@(Right d) = Right (d { index = clampIndex pres (d.index + 1)})
-- next other = other

-- previous :: Presentation -> Presentation
-- previous pres@(Right d) = Right (d { index = clampIndex pres (d.index - 1) })
-- previous other = other

-- reset :: Presentation -> Presentation
-- reset pres@(Right d) = Right (d { index = 0 })
-- reset other = other

error: pathspec 'src/model/Presentation.1.purs' did not match any file(s) known to git


Do not show base repr. if it's equal to the standard output

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array ((:), fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate)
import Data.List (sortBy, groupBy)
import Data.List.NonEmpty (head)
import Data.Maybe (Maybe(..))
import Data.String (toLower)
import Data.StrMap (lookup, insert, toList)
import Data.Tuple (fst, snd)

import Quantities (Quantity, UnificationError(..), pow, scalar', qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, prettyPrint', fullSimplify, derivedUnit, acos,
                   asin, atan, sin, cos, tan, exp, ln, sinh, cosh, tanh, asinh,
                   acosh, atanh, ceil, floor, log10, round, isFinite,
                   toStandardUnit, unity, toString, baseRepresentation)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))
import Insect.Environment (Environment, initialEnvironment)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | Types of errors that may appear during evaluation.
data EvalError
  = QUnificationError UnificationError
  | LookupError String
  | NumericalError

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | isFinite q = pure q
              | otherwise  = Left NumericalError

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → Quantity → Expect Quantity
applyFunction fn q = lmap QUnificationError $ (run fn) q
  where
    run Acos  = acos
    run Acosh = acosh
    run Asin  = asin
    run Asinh = asinh
    run Atan  = atan
    run Atanh = atanh
    run Ceil  = ceil
    run Cos   = cos
    run Cosh  = cosh
    run Exp   = exp
    run Floor = floor
    run Ln    = ln
    run Log10 = log10
    run Round = round
    run Sin   = sin
    run Sinh  = sinh
    run Sqrt  = sqrt >>> pure
    run Tan   = tan
    run Tanh  = tanh

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar' n
eval env (Unit u)        = pure $ quantity 1.0 u
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn x)    = eval env x >>= applyFunction fn >>= checkFinite
eval env (BinOp op x y)  = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y' >>= checkFinite
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract' a b
    run Add       a b = qAdd' a b
    run Mul       a b = pure (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = pow a <$> toScalar'' b
    run ConvertTo a b = convertTo' a b

    wrap ∷ ∀ a. Either UnificationError a → Either EvalError a
    wrap = lmap QUnificationError

    qSubtract' q1 q2 = wrap (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    convertTo' source target = wrap (convertTo source (derivedUnit target))

-- | Render the error message for a unification error.
unificationErrorMessage ∷ UnificationError → Markup
unificationErrorMessage (UnificationError u1 u2) =
  if u1 == unity
    then scalarErr u2
    else
      if u2 == unity
        then scalarErr u1
        else
            [ F.error "  Unification error:", F.nl, F.nl
            , F.text "    Cannot unify unit ", F.unit (toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "            with unit ", F.unit (toString u2)
            ] <> baseRep u2
  where
    scalarErr u =
      [ F.error "  Unification error:", F.nl, F.nl
      , F.text "    Cannot convert quantity of unit "
      , F.unit (toString u)
      , F.text " to a ", F.unit "scalar"
      ]
    baseRep u =
      if fst (toStandardUnit u) == unity
        then []
        else
          if toString u == F.format F.fmtPlain usStrs
            then []
            else br
      where
        br = F.text " (base units: " : usStrs <> [ F.text ")" ]
        us = baseRepresentation u
        us' = sortBy (comparing toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QUnificationError ue) =
  unificationErrorMessage ue
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> F.text "  " : prefix <> pretty expr)
                         <> (F.optional <$> [ F.nl, F.nl ])
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case (fullSimplify <$> eval env e) of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> F.text "  " : pretty e)
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: insert "ans" value env
      }
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → errorWithInput [ F.ident n, F.text " = " ] v env evalErr
    Right value' →
      let value = fullSimplify value'
      in { msg: Message ValueSet $
                     (F.optional <$> [ F.text "  ", F.ident n, F.text " = " ])
                  <> prettyQuantity value
         , newEnv: insert n value env
         }
runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text "/", F.val "16", F.text "*", F.val "9", F.text "             "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.unit "min", F.text " + ", F.val "30", F.unit "s", F.text "            "
  , F.emph "  > ", F.val "6", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.unit "h", F.text " -> ", F.unit "GB", F.val "", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.unit "km", F.text "/", F.ident "c", F.text " -> ", F.unit "ms", F.text "       "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    envTuples = sortBy (comparing (fst <<< prettyPrint' <<< snd)) $ toList env
    envGrouped = groupBy (\x y → snd x == snd y) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = snd (head kvPairs)
runInsect env (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }
runInsect env (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }
runInsect env (Command Clear) = { msg: MClear, newEnv: env }

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array ((:), fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate)
import Data.List (sortBy, groupBy)
import Data.List.NonEmpty (head)
import Data.Maybe (Maybe(..))
import Data.String (toLower)
import Data.StrMap (lookup, insert, toList)
import Data.Tuple (fst, snd)

import Quantities (Quantity, UnificationError(..), pow, scalar', qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, prettyPrint', fullSimplify, derivedUnit, acos,
                   asin, atan, sin, cos, tan, exp, ln, sinh, cosh, tanh, asinh,
                   acosh, atanh, ceil, floor, log10, round, isFinite,
                   toStandardUnit, unity, toString, baseRepresentation)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))
import Insect.Environment (Environment, initialEnvironment)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | Types of errors that may appear during evaluation.
data EvalError
  = QUnificationError UnificationError
  | LookupError String
  | NumericalError

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | isFinite q = pure q
              | otherwise  = Left NumericalError

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → Quantity → Expect Quantity
applyFunction fn q = lmap QUnificationError $ (run fn) q
  where
    run Acos  = acos
    run Acosh = acosh
    run Asin  = asin
    run Asinh = asinh
    run Atan  = atan
    run Atanh = atanh
    run Ceil  = ceil
    run Cos   = cos
    run Cosh  = cosh
    run Exp   = exp
    run Floor = floor
    run Ln    = ln
    run Log10 = log10
    run Round = round
    run Sin   = sin
    run Sinh  = sinh
    run Sqrt  = sqrt >>> pure
    run Tan   = tan
    run Tanh  = tanh

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar' n
eval env (Unit u)        = pure $ quantity 1.0 u
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn x)    = eval env x >>= applyFunction fn >>= checkFinite
eval env (BinOp op x y)  = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y' >>= checkFinite
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract' a b
    run Add       a b = qAdd' a b
    run Mul       a b = pure (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = pow a <$> toScalar'' b
    run ConvertTo a b = convertTo' a b

    wrap ∷ ∀ a. Either UnificationError a → Either EvalError a
    wrap = lmap QUnificationError

    qSubtract' q1 q2 = wrap (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    convertTo' source target = wrap (convertTo source (derivedUnit target))

-- | Render the error message for a unification error.
unificationErrorMessage ∷ UnificationError → Markup
unificationErrorMessage (UnificationError u1 u2) =
  if u1 == unity
    then scalarErr u2
    else
      if u2 == unity
        then scalarErr u1
        else
            [ F.error "  Unification error:", F.nl, F.nl
            , F.text "    Cannot unify unit ", F.unit (toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "            with unit ", F.unit (toString u2)
            ] <> baseRep u2
  where
    scalarErr u =
      [ F.error "  Unification error:", F.nl, F.nl
      , F.text "    Cannot convert quantity of unit "
      , F.unit (toString u)
      , F.text " to a ", F.unit "scalar"
      ]
    baseRep u =
      if fst (toStandardUnit u) == unity
        then []
        else F.text " (base units: " : usStrs <> [ F.text ")" ]
      where
        us = baseRepresentation u
        us' = sortBy (comparing toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QUnificationError ue) =
  unificationErrorMessage ue
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> F.text "  " : prefix <> pretty expr)
                         <> (F.optional <$> [ F.nl, F.nl ])
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case (fullSimplify <$> eval env e) of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> F.text "  " : pretty e)
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: insert "ans" value env
      }
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → errorWithInput [ F.ident n, F.text " = " ] v env evalErr
    Right value' →
      let value = fullSimplify value'
      in { msg: Message ValueSet $
                     (F.optional <$> [ F.text "  ", F.ident n, F.text " = " ])
                  <> prettyQuantity value
         , newEnv: insert n value env
         }
runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text "/", F.val "16", F.text "*", F.val "9", F.text "             "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.unit "min", F.text " + ", F.val "30", F.unit "s", F.text "            "
  , F.emph "  > ", F.val "6", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.unit "h", F.text " -> ", F.unit "GB", F.val "", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.unit "km", F.text "/", F.ident "c", F.text " -> ", F.unit "ms", F.text "       "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    envTuples = sortBy (comparing (fst <<< prettyPrint' <<< snd)) $ toList env
    envGrouped = groupBy (\x y → snd x == snd y) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = snd (head kvPairs)
runInsect env (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }
runInsect env (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }
runInsect env (Command Clear) = { msg: MClear, newEnv: env }


Factored out common function groupByTask.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/0dB/cats-utils.git/'


Removed two filler columns to match CATS table.


Purescript Gauge module

Purescript Gauge module

module Gauge where

import Prelude
import Pux.Html as H
import Control.Bind ((=<<))
import Control.Category (id)
import Data.Field (div)
import Data.Foldable (sum)
import Data.List
import Data.StrMap (empty)

data Action = UpdateStats (List NodeStats)
type State = (List NodeStats)

-- /todo: Add Node = String | IPAddress
type Node = String
type Broker =
    { name :: Node
    , port :: Int }
type BStats = Int
type BrokerStats =
    { broker ::Broker
    , stats :: BStats}

type NodeStats =
    { node ::  Node
    , brokers :: List BrokerStats}

numConnections :: List NodeStats -> Int
numConnections =
    concatMap _.brokers
    >>> map _.stats
    >>> sum

init :: State
init = Nil

update :: Action -> State -> State
update (UpdateStats us) s = us

view:: State -> H.Html Action
view state =
    H.div
    []
    [H.h1 [] [H.text "test" ]]

error: pathspec 'priv/src/Gauge.purs' did not match any file(s) known to git


4.11.3

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mikemcgowan/purescript-book.git/'


Another test

Another test

module Main where

data Proxy a = Proxy

test :: forall a. (Show (Proxy a)) => String
test = show Proxy

main = Debug.Trace.trace "Done"

error: pathspec 'examples/passing/UnknownInInstance.purs' did not match any file(s) known to git


Added ActionList component

Added ActionList component

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.ActionList.Component where

import SlamData.Prelude

import Data.Array as A
import Data.Foldable as F
import Data.Lens (Lens', lens, (.~))
import Data.String as S

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)

data Query a b
  = Selected (Action a) b
  | UpdateFilter String b
  | UpdateActions (Array (Action a)) b

type State a =
  { actions ∷ Array (Action a)
  , previousActions ∷ Array (Action a)
  , filterString ∷ String
  }

type HTML a = H.ComponentHTML (Query a)
type DSL a = H.ComponentDSL (State a) (Query a) Slam

newtype ActionIconUri = ActionIconUri String
newtype ActionName = ActionName String
newtype ActionDescription = ActionDescription String

data Action a
  = Do ActionName ActionIconUri ActionDescription a
  | Drill ActionName ActionIconUri ActionDescription (Array (Action a))
  | GoBack

_actions ∷ ∀ a r. Lens' { actions ∷ a |r } a
_actions = lens _.actions (_ { actions = _ })

_previousActions ∷ ∀ a r. Lens' { previousActions ∷ a | r} a
_previousActions = lens _.previousActions (_ { previousActions = _ })

_filterString ∷ ∀ a r. Lens' { filterString ∷ a | r } a
_filterString = lens _.filterString (_ { filterString = _ })

isDo ∷ ∀ a. Action a → Boolean
isDo (Do _ _ _ _) = true
isDo _ = false

isDrill ∷ ∀ a. Action a → Boolean
isDrill (Drill _ _ _ _) = true
isDrill _ = false

searchFilters ∷ ∀ a. Action a → Array String
searchFilters (Do (ActionName name) _ _ _) = [ name ]
searchFilters (Drill (ActionName name) _ _ actions) = [ name ] ⊕ A.concat (map searchFilters actions)
searchFilters (GoBack) = [ "go back" ]

derive newtype instance eqActionIconUri :: Eq ActionIconUri
derive newtype instance eqActionName :: Eq ActionName
derive newtype instance eqActionDescription :: Eq ActionDescription

instance eqAction ∷ Eq a ⇒ Eq (Action a) where
  eq GoBack GoBack = true
  eq (Do n1 i1 d1 a1) (Do n2 i2 d2 a2) =
    n1 ≡ n2
      ∧ i1 ≡ i2
      ∧ d1 ≡ d2
      ∧ a1 ≡ a2
  eq (Drill n1 i1 d1 a1) (Drill n2 i2 d2 a2) =
    n1 ≡ n2
      ∧ i1 ≡ i2
      ∧ d1 ≡ d2
      ∧ a1 ≡ a2
  eq _ _ = false

initialState ∷ ∀ a. State a
initialState =
  { actions: []
  , previousActions: [ ]
  , filterString: ""
  }

component ∷ ∀ a. Eq a ⇒ H.Component (State a) (Query a) Slam
component =
  H.component
    { render
    , eval
    }

render ∷ ∀ a. State a → HTML a
render state =
  HH.div_
    ([ HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input \s → UpdateFilter s)
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ $ UpdateFilter "")
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ]
    ] ⊕ [ HH.ul_ $ map nextButton state.actions ])
  where

  filterString ∷ String
  filterString = S.toLower state.filterString

  nextButton ∷ Action a → HTML a
  nextButton action =
    HH.li_
      [ HH.button attrs
          [ HH.img [ HP.src $ actionIconUri action ]
          , HH.p_ [ HH.text $ actionName action ]
          ]
      ]
    where
    enabled ∷ Boolean
    enabled = case action of
      GoBack → true
      _ → F.any (S.contains (S.Pattern filterString) ∘ S.toLower) $ searchFilters action

    attrs =
      [ HP.title $ actionDescription action
      , HP.disabled $ not enabled
      , ARIA.label $ actionDescription action
      , HP.classes classes
      , HE.onClick (HE.input_ $ Selected action)
      ]

    actionDescription ∷ Action a → String
    actionDescription = case _ of
      Do _ _ (ActionDescription s) _ → s
      Drill _ _ (ActionDescription s) _ → s
      GoBack → "Go back"

    actionIconUri ∷ Action a → String
    actionIconUri = case _ of
      Do _ (ActionIconUri s) _ _ → s
      Drill _ (ActionIconUri s) _ _ → s
      GoBack → ""

    actionName ∷ Action a → String
    actionName = case _ of
      Do (ActionName s) _ _ _ → s
      Drill (ActionName s) _ _ _ → s
      GoBack → "Go back"

    classes ∷ Array HH.ClassName
    classes = case action of
      Do _ _ _ _ →
        nonInsertableClassNames
      Drill _ _ _ actions | not (F.any isDo actions) →
        nonInsertableClassNames
      _ →
        insertableClassNames

    insertableClassNames =
      [ HH.className "sd-button" ]

    nonInsertableClassNames =
        [ HH.className "sd-button", HH.className "sd-button-warning" ]

updateActions ∷ ∀ a. Eq a ⇒ Array (Action a) → State a → State a
updateActions newActions state =
  case activeDrill of
    Nothing →
      state
        { actions = newActions }
    Just drill →
      state
        { previousActions = newActions
        , actions = fromMaybe [] $ pluckDrillActions =<< newActiveDrill
        }
  where
  activeDrill ∷ Maybe (Action a)
  activeDrill =
    F.find
      (maybe false (eq state.actions) ∘ pluckDrillActions)
      state.previousActions

  newActiveDrill =
    F.find (eq activeDrill ∘ Just) newActions

  pluckDrillActions = case _ of
    Drill _ _ _ xs → Just xs
    _ → Nothing

eval ∷ ∀ a. Eq a ⇒ Query a ~> DSL a
eval = case _ of
  UpdateFilter str next →
    H.modify (_filterString .~ str) $> next
  Selected action next → do
    st ← H.get
    case action of
      Do _ _ _ _ → pure unit
      Drill _ _ _ actions →
        H.modify
          $ (_actions .~ actions)
          ∘ (_previousActions .~ st.actions)
      GoBack →
        H.modify
          $ (_actions .~ st.previousActions)
          ∘ (_previousActions .~ [ ])
    pure next
  UpdateActions actions next →
    H.modify (updateActions actions) $> next

error: pathspec 'src/SlamData/ActionList/Component.purs' did not match any file(s) known to git


Add module for simpler testing in 'psci' (repl)

module Tests where

import Data.Either

import AST
import Parser
import Evaluator

testEnv :: Env
testEnv = defsToEnv $ case (Parser.parseDefs defs) of Right env -> env
  where
  defs = """
    double x = x + x
    fact 0 = 1
    fact n = n * fact (n - 1)
    fib 0 a b = a
    fib n a b = fib (n - 1) b (a + b)
    """

testExpr :: String -> Expr
testExpr str = case (Parser.parseExpr str) of Right expr -> expr

error: pathspec 'src/Tests.purs' did not match any file(s) known to git


Create Main.purs

Create Main.purs


don't need lambda forms in where clause

don't need lambda forms in where clause

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/michaelsbradleyjr/advent-of-code.git/'


Added a test that logging in with the wrong password fails.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/gcross/habit-of-fate.git/'


Small refactoring.

Small refactoring.

* extract the monadic value `unify` logic value pattern
* replace alt by disjunction (since it makes more sense in a logic program)

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/raduom/minos.git/'


~redo new track again~

~redo new track again~

module Genetics.Browser.TruTrack where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Reader (class MonadReader, Reader, ReaderT(..), ask, runReader, runReaderT)
import Control.MonadPlus (guard)
import Data.Array ((:))
import Data.Array as Array
import Data.Distributive (distribute)
import Data.Either (Either, Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, for_, length, maximum, minimum, sum)
import Data.List (List(..), mapMaybe)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Record.Unsafe (unsafeSet)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Unfoldable (unfoldr)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, Pos, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Graphics.Drawing (Drawing, translate)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
type Renderer a = { draw :: a -> Drawing
                  , point :: a -> Normalized Point
                  }

drawFrame :: forall a r.
             { width :: Pixels
             , padding :: Pixels
             , height :: Pixels
             , frame :: Frame (Array a) | r}
          -> Renderer a
          -> Drawing
drawFrame {width, padding, height, frame} {draw, point} = foldMap draw' frame.contents
  where draw' a = let {x,y} = nPointToFrame (width - padding * 2.0) height $ point a
                      drawing = draw a
                  in translate (x + padding) y drawing

offsets :: forall f r.
           Traversable f
        => f { width :: Pixels | r }
        -> f Pixels
offsets fs = scanl (\o {width} -> width + o) 0.0 fs

addOffsets :: forall k r.
              Ord k
           => Map k { width :: Pixels | r }
           -> Map k { width :: Pixels, offset :: Pixels | r }
addOffsets fs = zipMapsWith (unsafeSet "offset") os fs
  where os = offsets fs

-- We simply throw away existing width, offset, height data if it exists
fitFrames :: forall f a r.
             Foldable f
          => Pixels
          -> f { size :: Bp | r }
          -> f { width :: Pixels
               , offset :: Pixels | r }
fitFrames totalWidth fs = unsafeCoerce unit
  where totalSize = alaF Additive foldMap _.size fs
        w size = unwrap $ size / totalSize

-- TODO reasonable way of defining frame/track y-position, based on:

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

-- type Renderer eff a =
--   { hPos :: a -> XPosInfo -> Pixels
--   , vPos :: a -> YPosInfo -> Pixels
--   , render :: a -> Context2D -> Eff eff Unit
--   , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
--   }

-- gwasRenderer :: forall a.
--                 {min :: Number, max :: Number}
--              -> (a -> String)
--              -> Renderer _ {score :: Number, pos :: Bp, chr :: a}
-- gwasRenderer {min, max} color = { hPos, vPos, render, hit: Nothing }
--   where hPos a xInfo = posPixelsX xInfo a.pos
--         nScore s = (s - min) / (max - min)
--         vPos a yInfo = posPixelsY yInfo (nScore a.score)
--         render a ctx = renderGlyph ctx $ do
--           stroke (color a.chr)
--           fill (color a.chr)
--           circle { x: 0.0, y: 0.0 } 5.0

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

mkFrame :: forall r a.
            RowLacks "frame" (size :: Bp | r)
         => Pixels
         -> (Bp -> Pixels)
         -> {size :: Bp | r}
         -> a
         -> {size :: Bp, frame :: Frame a | r}
mkFrame padding getWidth chr a = chr'
  where chr' :: {size :: Bp, frame :: Frame a | r}
        chr' = insertFrame frame chr
        frame :: Frame a
        frame = { padding, width: getWidth chr.size, contents: a }

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

chrSubrange :: forall a r.
               Range r
            -> Map ChrId a
            -> Map ChrId a
chrSubrange {lHand, rHand} = Map.submap (Just lHand.chrId) (Just rHand.chrId)

-- renderFrame :: _
-- renderFrame = ?idk

fetchGemma :: String
           -> Aff _ (List { chr :: ChrId, pos :: Bp, score :: Number })
fetchGemma url = do
  liftEff $ log "fetching gwas"
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chr <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chr, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

error: pathspec 'src/Genetics/Browser/TruTrack.purs' did not match any file(s) known to git


Identity monad/functor

Identity monad/functor

module Control.Monad.Identity where

import Prelude

data Identity a = Identity a

runIdentity :: forall a. Identity a -> a
runIdentity (Identity x) = x

instance Prelude.Monad Identity where
  return = Identity
  (>>=) m f = f $ runIdentity m

instance Prelude.Applicative Identity where
  pure = Identity
  (<*>) (Identity f) (Identity x) = Identity $ f x

instance Prelude.Functor Identity where
  (<$>) f m = Identity $ f $ runIdentity m

error: pathspec 'src/Control.Monad.Identity.purs' did not match any file(s) known to git


Add Inject1 typeclass

Add Inject1 typeclass

module Control.Inject1 where

import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..))

class Inject1 a b where
  inj :: a -> b
  prj :: b -> Maybe a

instance inject1Reflexive :: Inject1 a a where
  inj = id
  prj = Just

instance inject1Left :: Inject1 a (Either a b) where
  inj = Left
  prj = either Just (const Nothing)

instance inject1Right :: (Inject1 a b) => Inject1 a (Either c b) where
  inj = Right <<< inj
  prj = either (const Nothing) prj

error: pathspec 'src/Control/Inject1.purs' did not match any file(s) known to git


Add Profunctor component instance

Add Profunctor component instance

module Halogen.Component.Profunctor (ProComponent(..)) where

import Prelude
import Control.Applicative.Free (hoistFreeAp)
import Control.Monad.Free (hoistFree)
import Data.Newtype (class Newtype, over)
import Data.Profunctor (class Profunctor, lmap)
import Halogen.Component as HC
import Halogen.Query.HalogenM as HM
import Halogen.Query.ForkF as FF

newtype ProComponent h f m i o = ProComponent (HC.Component h f i o m)

derive instance newtypeProComponent :: Newtype (ProComponent h f m i o) _

instance profunctorProComponent :: Profunctor (ProComponent h f m) where
  dimap = dimapProComponent

dimapProComponent
  :: forall h f m i i' o o'
   . (i' -> i)
  -> (o -> o')
  -> ProComponent h f m i o
  -> ProComponent h f m i' o'
dimapProComponent f g (ProComponent c) = ProComponent (HC.unComponent go c)
  where
  go :: forall s g p. HC.Component' h s f g p i o m -> HC.Component h f i' o' m
  go comp = HC.mkComponent $ comp
    { initialState = lmap f comp.initialState
    , receiver = lmap f comp.receiver
    , eval = mapOutput g <$> comp.eval
    }

mapOutput
  :: forall s f g p o o' m
   . (o -> o')
  -> HM.HalogenM s f g p o m
  ~> HM.HalogenM s f g p o' m
mapOutput f (HM.HalogenM h) = HM.HalogenM (hoistFree go h)
  where
  go :: HM.HalogenF s f g p o m ~> HM.HalogenF s f g p o' m
  go = case _ of
    HM.State s -> HM.State s
    HM.Subscribe es next -> HM.Subscribe es next
    HM.Lift q -> HM.Lift q
    HM.Halt msg -> HM.Halt msg
    HM.GetSlots k -> HM.GetSlots k
    HM.CheckSlot p k -> HM.CheckSlot p k
    HM.ChildQuery p cq -> HM.ChildQuery p cq
    HM.Raise o a -> HM.Raise (f o) a
    HM.Par p -> HM.Par (over HM.HalogenAp (hoistFreeAp (mapOutput f)) p)
    HM.Fork p -> HM.Fork (FF.hoistFork (mapOutput f) p)
    HM.GetRef p k -> HM.GetRef p k

error: pathspec 'src/Halogen/Component/Profunctor.purs' did not match any file(s) known to git


Remove Foo.

Remove Foo.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/ruicc/purescript-lifegame.git/'


Removed import of Data.These from test file.

It doesn't appear that the test file is actually using anything from the
Data.These module.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/Podlas29/purescript-css.git/'


Get context from menu

Get context from menu

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/clample/lambdabtc.git/'


Prevent flashing zoom button on dashboards (#1344)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component.Render
  ( render
  ) where

import SlamData.Prelude
import CSS as C
import Data.Array as Array
import Data.List (List)
import Data.List as List
import Data.Ratio as Ratio
import Data.Rational (Rational, (%))
import Data.Rational as Rational
import Halogen as H
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.HTML.CSS.Indexed as HC
import Halogen.Themes.Bootstrap3 as B
import Math as Math
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Component.Common (DraftboardHTML)
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..))
import SlamData.Workspace.Card.Draftboard.Component.State (State, MoveLocation(..), SplitLocation)
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.DeckId (DeckId, toString)

render ∷ CardOptions → State → DraftboardHTML
render opts st =
  HH.div
    [ HP.classes
        ([ HH.className "sd-draftboard" ]
         <> (HH.className "splitting" <$ guard (isJust st.splitOpts))
         <> (HH.className "sizing" <$ guard (isJust st.resizeLocation)))
    ]
    [ renderOuterEdge "top" Orn.Vertical Layout.SideA
    , renderOuterEdge "left" Orn.Horizontal Layout.SideA
    , renderOuterEdge "right" Orn.Horizontal Layout.SideB
    , renderOuterEdge "bottom" Orn.Vertical Layout.SideB
    , if not (List.null opts.deck.displayCursor) && st.layout == Pane.Cell Nothing
        then
          HH.div
            [ HP.classes [ HH.className "card-input-minimum-lod" ] ]
            [ HH.button
                [ ARIA.label "Zoom"
                , HP.title "Zoom"
                , HE.onClick (HE.input_ (left ∘ CC.ZoomIn))
                ]
                [ glyph B.glyphiconZoomIn
                , HH.text "Zoom"
                ]
            ]
        else
          HH.div
            [ HP.classes [ HH.className "sd-draftboard-root" ]
            , HP.ref (right ∘ H.action ∘ SetRoot)
            ]
            [ renderLayout opts st st.cellLayout st.edgeLayout
            , maybe (HH.text "") renderGuide st.splitLocation
            , maybe (HH.text "") renderMoving st.moveLocation
            ]
    ]

renderOuterEdge ∷ String → Orn.Orientation → Layout.SplitBias → DraftboardHTML
renderOuterEdge edge orn bias =
  HH.button
    [ HP.classes
        [ HH.className "sd-draftboard-edge"
        , HH.className ("sd-draftboard-edge-" <> edge)
        ]
    , HE.onMouseDown (HE.input (\e → right ∘ SplitStart orn bias false e))
    ]
    [ HH.span
        [ HP.classes [ HH.className "sd-draftboard-edge-mid" ]
        , HE.onMouseDown \e → do
            HEH.stopPropagation
            pure (Just (right (H.action (SplitStart orn bias true e))))
        ]
        [ ]
    ]

renderGuide ∷ SplitLocation → DraftboardHTML
renderGuide sp =
  HH.div
    [ HP.classes
        ([ HH.className "sd-draftboard-guide"
         , HH.className (Orn.toString sp.orientation)
         ] <> (HH.className "invalid" <$ guard (not sp.valid)))
    , HC.style do
        C.top (C.px sp.y)
        C.left (C.px sp.x)
        case sp.orientation of
          Orn.Horizontal → C.height (C.px sp.z)
          Orn.Vertical   → C.width (C.px sp.z)
    ]
    [ renderGuideLabel sp.ratio ]

renderGuideLabel ∷ Rational → DraftboardHTML
renderGuideLabel ratio =
  let ratio' = unRational ratio in
  HH.span
    [ HP.classes
        [ HH.className "sd-draftboard-guide-label"
        , if ratio > 1%2
            then HH.className "trailing"
            else HH.className "leading"
        ]
    ]
    [ HH.text (show (Ratio.numerator ratio') <> "/" <> show (Ratio.denominator ratio')) ]

renderMoving ∷ MoveLocation → DraftboardHTML
renderMoving = case _ of
  Floating x y →
    HH.div
      [ HP.classes
          [ HH.className "sd-draftboard-moving-icon"
          , HH.className "floating"
          ]
      , HC.style do
          C.left (C.px x)
          C.top (C.px y)
      ]
      [ ]
  Move { rect } →
    HH.div
      [ HP.classes
          [ HH.className "sd-draftboard-moving-icon"
          , HH.className "move"
          ]
      , HC.style do
          C.top (C.px rect.top)
          C.left (C.px rect.left)
          C.width (C.px rect.width)
          C.height (C.px rect.height)
      ]
      [ ]
  Group { rect } orn side →
    HH.div
      [ HP.classes
          [ HH.className "sd-draftboard-moving-icon"
          , HH.className "group"
          , HH.className (Orn.toString orn)
          , HH.className case side of
              Layout.SideA → "side-a"
              Layout.SideB → "side-b"
          ]
      , HC.style do
          C.top (C.px rect.top)
          C.left (C.px rect.left)
          C.width (C.px rect.width)
          C.height (C.px rect.height)
      ]
      [ ]

renderLayout ∷ CardOptions → State → List (Layout.Cell (Maybe DeckId) Number) → List (Layout.Edge Number) → DraftboardHTML
renderLayout opts st cells edges =
  HH.div
    [ HP.classes [ HH.className "sd-draftboard-layout" ] ] $
    map (renderCell opts st) (Array.fromFoldable cells) <>
    map (renderEdge st) (Array.fromFoldable edges)

renderCell ∷ CardOptions → State → Layout.Cell (Maybe DeckId) Number → DraftboardHTML
renderCell opts st { cursor, value, rect } =
  HH.div
    ([ HP.classes
         [ HH.className "sd-draftboard-cell"
         , HH.className if isJust value then "filled" else "empty"
         ]
     , HC.style do
         C.top (C.px rect.top)
         C.left (C.px rect.left)
         C.width (C.px rect.width)
         C.height (C.px rect.height)
     ] <> (maybe [] (\deckId → [ HP.key (toString deckId) ]) value))
    [ HH.div
        [ HP.classes [ HH.className "sd-draftboard-cell-content" ] ]
        case value of
          Just deckId →
            [ HH.slot deckId (mkDeckComponent deckId) ]
          _ →
            [ HH.div
                [ HP.classes [ HH.className "sd-draftboard-cell-empty" ] ]
                [ HH.button
                    [ HP.classes [ HH.className "insert-cell" ]
                    , HP.title "Insert deck"
                    , ARIA.label "Insert deck"
                    , HE.onClick (HE.input_ (right ∘ AddDeck cursor))
                    , HC.style do
                        let
                          size = Math.min 140.0 (Math.min rect.width rect.height)
                        C.top (C.pct 50.0)
                        C.left (C.pct 50.0)
                        C.marginTop (C.px (size / -2.0))
                        C.marginLeft (C.px (size / -2.0))
                        C.width (C.px size)
                        C.height (C.px size)
                    ]
                    [ HH.span_ [] ]
                , HH.button
                    [ HP.classes [ HH.className "delete-cell" ]
                    , HP.title "Delete cell"
                    , ARIA.label "Delete cell"
                    , HE.onClick (HE.input_ (right ∘ DeleteCell cursor))
                    ]
                    [ HH.text "×"]
                ]
            ]
    ]
  where
  mkDeckComponent deckId _ =
    let
      deckOpts =
        { accessType: opts.deck.accessType
        , cursor: opts.cursor
        , displayCursor: opts.displayCursor
        , deckId
        }
    in
      { component: opts.deckComponent deckOpts
      , initialState: DNS.initialState
      }

renderEdge ∷ State → Layout.Edge Number → DraftboardHTML
renderEdge st edge@{ orientation, vect } =
  if fromMaybe false ((\loc → Layout.eqEdge edge loc.edge) <$> st.resizeLocation)
    then
      st.resizeLocation # maybe (HH.text "") \loc →
      let ord = compare loc.ratio edge.ratio in
      HH.button
        [ HP.classes
            ([ HH.className "sd-draftboard-split-edge"
             , HH.className (Orn.toString orientation)
             , HH.className "sizing"
             , HH.className
                 case ord of
                   LT → "lt"
                   GT → "gt"
                   EQ → "eq"
             ] <> (HH.className "invalid" <$ guard (not loc.valid)))
        , HC.style
            case orientation of
              Orn.Horizontal → do
                C.top (C.px vect.y)
                C.left (C.px (vect.x + loc.offset))
                C.height (C.px vect.z)
              Orn.Vertical → do
                C.top (C.px (vect.y + loc.offset))
                C.left (C.px vect.x)
                C.width (C.px vect.z)
        , HE.onMouseMove (\e → HEH.preventDefault $> Nothing)
        ]
        [ renderGuideLabel loc.ratio
        , HH.div
            [ HP.classes [ HH.className "sd-draftboard-split-edge-loc" ]
            , HC.style
                case orientation of
                  Orn.Horizontal →
                    C.width (C.px (Math.abs loc.offset))
                  Orn.Vertical →
                    C.height (C.px (Math.abs loc.offset))
            ]
            [ ]
        ]

    else
      HH.button
        [ HP.classes
            [ HH.className "sd-draftboard-split-edge"
            , HH.className (Orn.toString orientation)
            ]
        , HE.onMouseDown (HE.input \a _ → right (H.action (ResizeStart edge a)))
        , HC.style do
            C.top (C.px vect.y)
            C.left (C.px vect.x)
            case orientation of
              Orn.Horizontal → C.height (C.px vect.z)
              Orn.Vertical   → C.width (C.px vect.z)
        ]
        [ ]

unRational ∷ Rational → Ratio.Ratio Int
unRational (Rational.Rational a) = a

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component.Render
  ( render
  ) where

import SlamData.Prelude
import CSS as C
import Data.Array as Array
import Data.List (List)
import Data.List as List
import Data.Ratio as Ratio
import Data.Rational (Rational, (%))
import Data.Rational as Rational
import Halogen as H
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.HTML.CSS.Indexed as HC
import Halogen.Themes.Bootstrap3 as B
import Math as Math
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Component.Common (DraftboardHTML)
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..))
import SlamData.Workspace.Card.Draftboard.Component.State (State, MoveLocation(..), SplitLocation)
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.DeckId (DeckId, toString)

render ∷ CardOptions → State → DraftboardHTML
render opts st =
  HH.div
    [ HP.classes
        ([ HH.className "sd-draftboard" ]
         <> (HH.className "splitting" <$ guard (isJust st.splitOpts))
         <> (HH.className "sizing" <$ guard (isJust st.resizeLocation)))
    ]
    [ renderOuterEdge "top" Orn.Vertical Layout.SideA
    , renderOuterEdge "left" Orn.Horizontal Layout.SideA
    , renderOuterEdge "right" Orn.Horizontal Layout.SideB
    , renderOuterEdge "bottom" Orn.Vertical Layout.SideB
    , if not (List.null opts.deck.cursor) && st.layout == Pane.Cell Nothing
        then
          HH.div
            [ HP.classes [ HH.className "card-input-minimum-lod" ] ]
            [ HH.button
                [ ARIA.label "Zoom"
                , HP.title "Zoom"
                , HE.onClick (HE.input_ (left ∘ CC.ZoomIn))
                ]
                [ glyph B.glyphiconZoomIn
                , HH.text "Zoom"
                ]
            ]
        else
          HH.div
            [ HP.classes [ HH.className "sd-draftboard-root" ]
            , HP.ref (right ∘ H.action ∘ SetRoot)
            ]
            [ renderLayout opts st st.cellLayout st.edgeLayout
            , maybe (HH.text "") renderGuide st.splitLocation
            , maybe (HH.text "") renderMoving st.moveLocation
            ]
    ]

renderOuterEdge ∷ String → Orn.Orientation → Layout.SplitBias → DraftboardHTML
renderOuterEdge edge orn bias =
  HH.button
    [ HP.classes
        [ HH.className "sd-draftboard-edge"
        , HH.className ("sd-draftboard-edge-" <> edge)
        ]
    , HE.onMouseDown (HE.input (\e → right ∘ SplitStart orn bias false e))
    ]
    [ HH.span
        [ HP.classes [ HH.className "sd-draftboard-edge-mid" ]
        , HE.onMouseDown \e → do
            HEH.stopPropagation
            pure (Just (right (H.action (SplitStart orn bias true e))))
        ]
        [ ]
    ]

renderGuide ∷ SplitLocation → DraftboardHTML
renderGuide sp =
  HH.div
    [ HP.classes
        ([ HH.className "sd-draftboard-guide"
         , HH.className (Orn.toString sp.orientation)
         ] <> (HH.className "invalid" <$ guard (not sp.valid)))
    , HC.style do
        C.top (C.px sp.y)
        C.left (C.px sp.x)
        case sp.orientation of
          Orn.Horizontal → C.height (C.px sp.z)
          Orn.Vertical   → C.width (C.px sp.z)
    ]
    [ renderGuideLabel sp.ratio ]

renderGuideLabel ∷ Rational → DraftboardHTML
renderGuideLabel ratio =
  let ratio' = unRational ratio in
  HH.span
    [ HP.classes
        [ HH.className "sd-draftboard-guide-label"
        , if ratio > 1%2
            then HH.className "trailing"
            else HH.className "leading"
        ]
    ]
    [ HH.text (show (Ratio.numerator ratio') <> "/" <> show (Ratio.denominator ratio')) ]

renderMoving ∷ MoveLocation → DraftboardHTML
renderMoving = case _ of
  Floating x y →
    HH.div
      [ HP.classes
          [ HH.className "sd-draftboard-moving-icon"
          , HH.className "floating"
          ]
      , HC.style do
          C.left (C.px x)
          C.top (C.px y)
      ]
      [ ]
  Move { rect } →
    HH.div
      [ HP.classes
          [ HH.className "sd-draftboard-moving-icon"
          , HH.className "move"
          ]
      , HC.style do
          C.top (C.px rect.top)
          C.left (C.px rect.left)
          C.width (C.px rect.width)
          C.height (C.px rect.height)
      ]
      [ ]
  Group { rect } orn side →
    HH.div
      [ HP.classes
          [ HH.className "sd-draftboard-moving-icon"
          , HH.className "group"
          , HH.className (Orn.toString orn)
          , HH.className case side of
              Layout.SideA → "side-a"
              Layout.SideB → "side-b"
          ]
      , HC.style do
          C.top (C.px rect.top)
          C.left (C.px rect.left)
          C.width (C.px rect.width)
          C.height (C.px rect.height)
      ]
      [ ]

renderLayout ∷ CardOptions → State → List (Layout.Cell (Maybe DeckId) Number) → List (Layout.Edge Number) → DraftboardHTML
renderLayout opts st cells edges =
  HH.div
    [ HP.classes [ HH.className "sd-draftboard-layout" ] ] $
    map (renderCell opts st) (Array.fromFoldable cells) <>
    map (renderEdge st) (Array.fromFoldable edges)

renderCell ∷ CardOptions → State → Layout.Cell (Maybe DeckId) Number → DraftboardHTML
renderCell opts st { cursor, value, rect } =
  HH.div
    ([ HP.classes
         [ HH.className "sd-draftboard-cell"
         , HH.className if isJust value then "filled" else "empty"
         ]
     , HC.style do
         C.top (C.px rect.top)
         C.left (C.px rect.left)
         C.width (C.px rect.width)
         C.height (C.px rect.height)
     ] <> (maybe [] (\deckId → [ HP.key (toString deckId) ]) value))
    [ HH.div
        [ HP.classes [ HH.className "sd-draftboard-cell-content" ] ]
        case value of
          Just deckId →
            [ HH.slot deckId (mkDeckComponent deckId) ]
          _ →
            [ HH.div
                [ HP.classes [ HH.className "sd-draftboard-cell-empty" ] ]
                [ HH.button
                    [ HP.classes [ HH.className "insert-cell" ]
                    , HP.title "Insert deck"
                    , ARIA.label "Insert deck"
                    , HE.onClick (HE.input_ (right ∘ AddDeck cursor))
                    , HC.style do
                        let
                          size = Math.min 140.0 (Math.min rect.width rect.height)
                        C.top (C.pct 50.0)
                        C.left (C.pct 50.0)
                        C.marginTop (C.px (size / -2.0))
                        C.marginLeft (C.px (size / -2.0))
                        C.width (C.px size)
                        C.height (C.px size)
                    ]
                    [ HH.span_ [] ]
                , HH.button
                    [ HP.classes [ HH.className "delete-cell" ]
                    , HP.title "Delete cell"
                    , ARIA.label "Delete cell"
                    , HE.onClick (HE.input_ (right ∘ DeleteCell cursor))
                    ]
                    [ HH.text "×"]
                ]
            ]
    ]
  where
  mkDeckComponent deckId _ =
    let
      deckOpts =
        { accessType: opts.deck.accessType
        , cursor: opts.cursor
        , displayCursor: opts.displayCursor
        , deckId
        }
    in
      { component: opts.deckComponent deckOpts
      , initialState: DNS.initialState
      }

renderEdge ∷ State → Layout.Edge Number → DraftboardHTML
renderEdge st edge@{ orientation, vect } =
  if fromMaybe false ((\loc → Layout.eqEdge edge loc.edge) <$> st.resizeLocation)
    then
      st.resizeLocation # maybe (HH.text "") \loc →
      let ord = compare loc.ratio edge.ratio in
      HH.button
        [ HP.classes
            ([ HH.className "sd-draftboard-split-edge"
             , HH.className (Orn.toString orientation)
             , HH.className "sizing"
             , HH.className
                 case ord of
                   LT → "lt"
                   GT → "gt"
                   EQ → "eq"
             ] <> (HH.className "invalid" <$ guard (not loc.valid)))
        , HC.style
            case orientation of
              Orn.Horizontal → do
                C.top (C.px vect.y)
                C.left (C.px (vect.x + loc.offset))
                C.height (C.px vect.z)
              Orn.Vertical → do
                C.top (C.px (vect.y + loc.offset))
                C.left (C.px vect.x)
                C.width (C.px vect.z)
        , HE.onMouseMove (\e → HEH.preventDefault $> Nothing)
        ]
        [ renderGuideLabel loc.ratio
        , HH.div
            [ HP.classes [ HH.className "sd-draftboard-split-edge-loc" ]
            , HC.style
                case orientation of
                  Orn.Horizontal →
                    C.width (C.px (Math.abs loc.offset))
                  Orn.Vertical →
                    C.height (C.px (Math.abs loc.offset))
            ]
            [ ]
        ]

    else
      HH.button
        [ HP.classes
            [ HH.className "sd-draftboard-split-edge"
            , HH.className (Orn.toString orientation)
            ]
        , HE.onMouseDown (HE.input \a _ → right (H.action (ResizeStart edge a)))
        , HC.style do
            C.top (C.px vect.y)
            C.left (C.px vect.x)
            case orientation of
              Orn.Horizontal → C.height (C.px vect.z)
              Orn.Vertical   → C.width (C.px vect.z)
        ]
        [ ]

unRational ∷ Rational → Ratio.Ratio Int
unRational (Rational.Rational a) = a


Grouping by task while spreading Sonstiges working. Code re-arrangement.


Added import to get new type of ui() right.


Test applicative style

Test applicative style

module Main where

  import Prelude
  import Either
  import JSON
  import Monad
  import Arrays

  foreign import toJSON "function toJSON (obj) { return obj; }" :: forall a. a -> JSON

  showUnsafe :: forall a. a -> String
  showUnsafe = showJSON <<< toJSON

  class ReadJSON a where
    readJSON :: JSONParser a

  instance ReadJSON Number where
    readJSON = num

  readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
  readJSONProp p j = (prop p j) >>= readJSON

  data Item = Item Number Number Number

  instance ReadJSON Item where
    readJSON json = Item <$> (readJSONProp "x" json)
                         <*> (readJSONProp "y" json)
                         <*> (readJSONProp "z" json)

  main = do
    let obj = fromString "{\"x\":1,\"y\":2,\"z\":3}"
    case obj of
      Left err -> Trace.print $ "Error parsing: " ++ err
      Right obj -> case readJSON obj of
        Left err -> Trace.print err
        Right (Item x y z) -> Trace.print [x, y, z]

error: pathspec 'test-applicative.purs' did not match any file(s) known to git


Quick fix support/initial

Quick fix support/initial

module IdePurescript.QuickFix where

-- | Get a title which explains what applying a compiler suggestion will do
getTitle :: String -> String
getTitle code = case code of
  "UnusedImport"                -> "Remove import"
  "RedundantEmptyHidingImport"  -> "Remove import"
  "DuplicateImport"             -> "Remove import"
  "RedundantUnqualifiedImport"  -> "Remove import"
  "DeprecatedQualifiedSyntax"   -> "Remove qualified keyword"
  "ImplicitImport"              -> "Make import explicit"
  "UnusedExplicitImport"        -> "Remove unused references"
  _                             -> "Apply Suggestion"

-- | Determine whether an error code represents an unknown token (unknown identifier or missing import)
isUnknownToken :: String -> Boolean
isUnknownToken code = case code of
  "UnknownValue" -> true
  "UnknownType" -> true
  "UnknownDataConstructor" -> true
  "UnknownTypeConstructor" -> true
  _ -> false

error: pathspec 'src/IdePurescript/QuickFix.purs' did not match any file(s) known to git


factored out module Data.Chol from Data.Cov

module Data.Chol (doCholdc, doCholInv)
  where

import Prelude
import Prelude.Extended ( uidx, uJust, error, fromList, range )
import Math ( abs, sqrt )
import Data.Foldable ( sum )

import Data.Array (
    replicate
  , take
  ) as A
import Control.Monad.ST ( ST )
import Control.Monad.ST ( run, for ) as ST
import Data.Array.ST ( STArray )
import Data.Array.ST ( peek, poke, unsafeFreeze, thaw ) as STA

indV :: Int -> Int -> Int -> Int
indV w i0 j0 = (i0*w+j0)
indVs :: Int -> Int -> Int -> Int
indVs w i0 j0 | i0 <= j0   = (i0*w - (i0*(i0-1)) `div` 2 + j0-i0)
              | otherwise = (j0*w - (j0*(j0-1)) `div` 2 + i0-j0)
run :: forall a. (forall r. ST r (STArray r a)) -> Array a
run act = ST.run (act >>= STA.unsafeFreeze)

-- CHOLESKY DECOMPOSITION

-- | Simple Cholesky decomposition of a symmetric, positive definite matrix.
--   The result for a matrix /M/ is a lower triangular matrix /L/ such that:
--
--   * /M = LL^T/.
--
--   Example:
--
-- >            (  2 -1  0 )   (  1.41  0     0    )
-- >            ( -1  2 -1 )   ( -0.70  1.22  0    )
-- > choldx     (  0 -1  2 ) = (  0.00 -0.81  1.15 )
--
-- Given a positive-deﬁnite symmetric matrix a[1..n][1..n],
-- this routine constructs its Cholesky decomposition,
-- A = L · L^T
-- The Cholesky factor L is returned in the lower triangle of a,
-- except for its diagonal elements which are returned in p[1..n].

doCholdc :: Array Number -> Int -> Array Number
doCholdc a n = a' where
  ll = n*n
  l = run (do
    arr <- STA.thaw (A.replicate (ll+n+1) 0.0)
    -- loop over input array using Numerical Recipies algorithm (chapter 2.9)
    let ixa = indVs n
        ixarr = indV n
    ST.for 0 n \i0 -> do
      ST.for i0 n \j0 -> do
        let aij = uidx a (ixa i0 j0)
        _  <- if i0==j0
                    then STA.poke (ll+i0) aij arr
                    else STA.poke (ixarr j0 i0) aij arr
        ST.for 0 (i0+1) \k0 -> do

{-- peekSTArray :: forall a h r. STArray h a -> Int -> Eff (st :: ST h | r) (Maybe a) --}
{-- peek :: forall h a.          Int -> STArray h a -> ST h (Maybe a) --}
  {-- ST.run (do --}
  {--   arr <- STA.thaw [1, 2, 3] --}
  {--   STA.peek 2 arr) == Just 3 --}

          maik <- STA.peek (ixarr i0 k0) arr
          majk <- STA.peek (ixarr j0 k0) arr
          maij <- if i0==j0
                    then STA.peek (ll+i0) arr
                    else STA.peek (ixarr j0 i0) arr
          let sum = (uJust maij) - (uJust maik) * (uJust majk)
          void $ if i0==j0
                    then STA.poke (ll+i0) sum arr
                    else STA.poke (ixarr j0 i0) sum arr
        msum <- if i0==j0
                    then STA.peek (ll+i0) arr
                    else STA.peek (ixarr j0 i0) arr
        let sum = if i0==j0 && (uJust msum) < 0.0
                    then error ("choldc: not a positive definite matrix " <> show a)
                    else (uJust msum)
        mp_i' <- STA.peek (ll+i0) arr
        let p_i = if i0 == j0 then sqrt sum else (uJust mp_i')
        void $ if i0==j0
                    then STA.poke (ll+i0) p_i arr
                    else STA.poke (ixarr j0 i0) (sum/p_i) arr
        pure $ unit

    -- copy diagonal back into array
    ST.for 0 n \i0 -> do
      maii <- STA.peek (ll+i0) arr
      void $ STA.poke (ixarr i0 i0) (uJust maii) arr

    pure arr)
  a' = A.take (n*n) l

-- | Matrix inversion using Cholesky decomposition
-- | based on Numerical Recipies formula in 2.9
--
doCholInv :: Array Number -> Int -> Array Number
doCholInv a n = a' where
  ll = n*n
  l = run (do -- make a STArray of n x n + space for diagonal +1 for summing
    arr <- STA.thaw (A.replicate (ll+n+1) 0.0)
    -- loop over input array using Numerical Recipies algorithm (chapter 2.9)
    let ixa = indVs n
        ixarr = indV n
    ST.for 0 n \i0 -> do
      ST.for i0 n \j0 -> do
        let aij = uidx a (ixa i0 j0)
        void $ if i0==j0
                  then STA.poke (ll+i0) aij arr
                  else STA.poke (ixarr j0 i0) aij arr
        ST.for 0 (i0+1) \k0 -> do
          maik <- STA.peek (ixarr i0 k0) arr
          majk <- STA.peek (ixarr j0 k0) arr
          maij <- if i0==j0
                      then STA.peek (ll+i0) arr
                      else STA.peek (ixarr j0 i0) arr
          let sum = (uJust maij) - (uJust maik) * (uJust majk)
          void $ if i0==j0
                    then STA.poke (ll+i0) sum arr
                    else STA.poke (ixarr j0 i0) sum arr
        msum <- if i0==j0
                    then STA.peek (ll+i0) arr
                    else STA.peek (ixarr j0 i0) arr
        let sum = if i0==j0 && (uJust msum) < 0.0
                    then error ("choldInv: not a positive definite matrix " <> show a)
                    else (uJust msum)
        mp_i' <- STA.peek (ll+i0) arr
        let p_i = if i0 == j0
                      then sqrt sum
                      else (uJust mp_i')
        void $ if i0==j0
                  then STA.poke (ll+i0) p_i arr
                  else STA.poke (ixarr j0 i0) (sum/p_i) arr
        pure $ unit

    -- invert L -> L^(-1)
    ST.for 0 n \i0 -> do
      mp_i <- STA.peek (ll+i0) arr
      void $ STA.poke (ixarr i0 i0) (1.0/(uJust mp_i)) arr
      ST.for (i0+1) n \j0 -> do
        void $ STA.poke (ll+n) 0.0 arr
        ST.for i0 (j0+1) \k0 -> do
          majk <- STA.peek (ixarr j0 k0) arr
          maki <- STA.peek (ixarr k0 i0) arr
          sum <- STA.peek (ll+n) arr
          void $ STA.poke (ll+n) ((uJust sum) - (uJust majk) * (uJust maki)) arr
        msum <- STA.peek (ll+n) arr
        mp_j <- STA.peek (ll+j0) arr
        void $ STA.poke (ixarr j0 i0) ((uJust msum)/(uJust mp_j)) arr
    pure arr)

  a' = fromList $ do
    let idx = indV n
    i0 <- range 0 (n-1)
    j0 <- range i0 (n-1)
    let aij = sum $ do
                  k0 <- range 0 (n-1)
                  pure $ (uidx l (idx k0 i0)) * (uidx l (idx k0 j0))
    pure $ aij

--C version Numerical Recipies 2.9
--for (i=1;i<=n;i++) {
--  for (j=i;j<=n;j++) {
--    for (sum=a[i][j],k=i-1;k>=1;k--) sum -= a[i][k]*a[j][k];
--    if (i == j) {
--      if (sum <= 0.0) nrerror("choldc failed");
--      p[i]=sqrt(sum);
--    } else a[j][i]=sum/p[i];
--  }
--}
-- In this, and many other applications, one often needs L^(−1) . The lower
-- triangle of this matrix can be efﬁciently found from the output of choldc:
--for (i=1;i<=n;i++) {
--  a[i][i]=1.0/p[i];
--  for (j=i+1;j<=n;j++) {
--    sum=0.0;
--    for (k=i;k<j;k++) sum -= a[j][k]*a[k][i];
--    a[j][i]=sum/p[j];
--  }
--}

error: pathspec 'src/Data/Chol.purs' did not match any file(s) known to git


add Request.GetSpot

add Request.GetSpot

module Request.GetSpot (getSpot) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Except (runExcept)
import Data.Either (either)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.GetSpotResponse (GetSpotResponse)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, show)

getSpot :: forall eff
               . Int
               -> String
               -> Aff ( http :: HTTP
                      | eff
                      ) GetSpotResponse
getSpot spotId token = do
  text <- fetch options
  let f = readJSON text :: F GetSpotResponse
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    url = ( "https://api.rallyapp.jp/spots/"
          <> show spotId
          <> "?view_type=admin"
          )
    options = FetchOptions.method := FetchOptions.GET
              <> FetchOptions.url := url
              <> FetchOptions.headers := headers

error: pathspec 'src/Request/GetSpot.purs' did not match any file(s) known to git