{-# language RecordWildCards #-}
{-# options_ghc -Wno-type-defaults #-}

{- |
Module      : UI.WX.Viewer
Description : Interactive view based on wxWidgets
-}
module UI.WX.Viewer ( wxView
                    ) where

import Data.Planar
import UI.Tile

import           Graphics.UI.WX hiding (pt)
import           qualified Graphics.UI.WX as WX
import           Graphics.UI.WXCore.Draw
import           Graphics.UI.WXCore.WxcClassTypes
import           Graphics.UI.WXCore.WxcTypes      (rgba)
import           Graphics.UI.WXCore.WxcClassesAL
import           Graphics.UI.WXCore.WxcClassesMZ

import Graphics.UI.WXCore.Events

import Control.Concurrent
import Data.Time (diffUTCTime, getCurrentTime)
import Data.IORef
import Text.Printf
import Control.Monad (forM_)
import Data.Functor ((<&>))
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set

import UI
import UI.WxWidgets

import Actor.Viewer

import Data.Word
import Foreign (Ptr)
import Data.Complex

data Model = Model
  { modelCenter   :: (Double, Double)
  , modelPixelDim :: (Double, Double)
  }

modelToRect :: Planar a => (Int,Int) -> Model -> Rectangle a
modelToRect (w,h) Model{..} = flippedRectangle (fromCoords ul) (fromCoords lr)
  where
    ul = (cx - px * fromIntegral w / 2, cy - py * fromIntegral h / 2)
    lr = (cx + px * fromIntegral w / 2, cy + py * fromIntegral h / 2)
    (cx, cy) = modelCenter
    (px, py) = modelPixelDim

interpolateModel :: Double -> Model -> Model -> Model
interpolateModel t m1 m2 = m2
    { modelCenter   = interpolate modelCenter
    , modelPixelDim = logInterpolate modelPixelDim
    }
  where
    interp p q = p + t * (q - p)
    interp2 (p1,p2) (q1,q2) = (interp p1 q1, interp p2 q2)
    interpolate f = interp2 (f m1) (f m2)
    logInterp p q = p * (q/p) ** t
    logInterp2  (p1,p2) (q1,q2) = (logInterp p1 q1, logInterp p2 q2)
    logInterpolate f = logInterp2 (f m1) (f m2)

helloFrom :: String -> IO ()
helloFrom me = do
    tid <- myThreadId
    bound <- isCurrentThreadBound
    capInfo <- threadCapability tid
    putStrLn ("Hello from " ++ me
              ++ ", on thread " ++ show tid
              ++ " cap=" ++ show capInfo
              ++ " bound=" ++ show bound)

-- | Create a window with an interactive view of a complex-dynamical system.
wxView :: Rectangle (Double, Double)
          -- ^ The upper-left and lower-right corners of the view.
       -> (Word32 -> Word32 -> Complex Double -> Complex Double -> Ptr Word8 -> IO ()) -- ([(Double, Double)] -> IO [Color])
          -- ^ The rendering action
       -> Viewer
          -- ^ The script-defined viewer
       -> IO ()
wxView _modelRect renderAction testViewer = start $ do

    model <- variable [value := Model (0,0) (1/128,1/128)]

    helloFrom "wxView"

    let (width, height) = (512, 512)

    -- Create the main viewer frame
    f <- frame [ text := "FractalStream"
               , clientSize := sz width height ]

    _myViewer <- toUI @WX testViewer ()

    -- Create a "simple complex dynamics" wizard
    do
      wiz <- frame [ text := "Parametric complex dynamics" ]

      p <- panel wiz [ clientSize := sz 200 200 ]

      initialZ <- textEntry p [ text := "0" ]
      fun <- textEntry p [ text := "z^2 + C" ]
      stopWhen <- textEntry p [ text := "|z| > maxRadius" ]

      set wiz [ layout := margin 10 $ container p $ grid 10 10 $
                [ [ widget (label "Starting from z = "), hfill (widget initialZ) ]
                , [ widget (label "Iterate f(z) = "), hfill (widget fun) ]
                , [ widget (label "         until "), hfill (widget stopWhen) ]]
              ]

    -- Create a code editor frame
    ce <- frame [ text := "Script editor"
                , clientSize := sz 300 300 ]
    cep <- panel ce [ clientSize := sz 100 100 ]
    stc <- styledTextCtrl cep [ clientSize := sz 100 100 ]
    styledTextCtrlSetMarginWidth stc 0 30
    styledTextCtrlSetMarginWidth stc 1 0
    styledTextCtrlSetMarginWidth stc 2 0
    -- see Style Definition at https://www.scintilla.org/ScintillaDoc.html#Styling
    lum <- do
      col <- get ce bgcolor
      let rc :: Float = colorRed col / 255
          gc = colorGreen col / 255
          bc = colorBlue col / 255
      pure (0.299 * rc + 0.587 * gc + 0.114 * bc)
    if lum > 0.5
      then do
        styledTextCtrlStyleSetSpec stc  0 "fore:#000000,back:#f8f8f8"
        styledTextCtrlStyleSetSpec stc 32 "fore:#000000,back:#f8f8f8"
        styledTextCtrlStyleSetSpec stc 33 "fore:#808080,back:#f0f060"
        styledTextCtrlSetCaretLineBackground stc (rgb 240 240 255)
      else do
        styledTextCtrlStyleSetSpec stc  0 "fore:#dbdbdb,back:#14191e"
        styledTextCtrlStyleSetSpec stc 32 "fore:#dbdbdb,back:#14191e"
        styledTextCtrlStyleSetSpec stc 33 "fore:#a0a0a0,back:#101040"
        styledTextCtrlSetCaretLineBackground stc (rgb 0x20 0x30 0x38)

    styledTextCtrlStyleSetFaceName stc 0 "Monaco"
    -- Set the minimum size, or else Scintilla will default to 2000 pixels(!)
    styledTextCtrlSetScrollWidth stc 100
    styledTextCtrlSetCaretLineVisible stc True

    styledTextCtrlSetUseTabs stc False
    styledTextCtrlSetTabWidth stc 4
    styledTextCtrlSetIndent stc 4
    styledTextCtrlSetTabIndents stc True
    styledTextCtrlSetBackSpaceUnIndents stc True
    --styledTextCtrlSetIndentationGuides stc True
    styledTextCtrlSetViewWhiteSpace stc 3

    seFileMenu <- menuPane [ text := "&File" ]
    menuItem seFileMenu [ text := "&Open..."
                        , on command := putStrLn "TODO" ]
    seEditMenu <- menuPane [ text := "&Edit" ]
    --menuItem seEditMenu [ text := "Copy\tCtrl-C" ]
    --menuItem seEditMenu [ text := "Cut\tCtrl-X" ]
    --menuItem seEditMenu [ text := "Paste\tCtrl-V" ]
    seHelpMenu  <- menuHelp      [ text := "&Help" ]
    --seAboutMenu <- menuAbout seHelpMenu [text := "About FractalStream"]
    set ce [ menuBar := [ seFileMenu
                        , seEditMenu
                        , seHelpMenu
                        ] ]

    titleBox <- textEntry cep [ text := "" ]

    lc <- listView cep [ "Variable", "Initial value", "Type", "Label" ] id

    listViewAddItem lc ["maxRadius", "10", "ℝ", "Escape radius"]
    listViewAddItem lc ["maxIters", "100", "ℕ", "Iteration limit"]
    listViewAddItem lc ["exterior", "blue", "Color", "Exterior color"]

    addParam <- button cep [ text := "Add parameter..." ]
    delParam <- button cep [ text := "Delete parameter" ]

    set ce [ layout := container cep $ column 1
               [ hstretch
                 $ margin 5
                 $ row 5 [ widget (label "Title:")
                         , fill (widget titleBox) ]
               , fill $ widget stc
               , hstretch
                 $ margin 10
                 $ row 5 [ column 5 [ widget (label "Parameters")
                                    , vglue
                                    , widget addParam
                                    , widget delParam ]
                         , fill (widget $ listViewLayout lc) ]
               ]
           , clientSize := sz 400 400 ]

    -- Test dialog
    dlog <- dialog ce [ text := "Edit parameter"
                      , resizeable := True
                      , on resize := propagateEvent
                      , visible := False ]
    dlog_ok <- button dlog [ text := "Ok" ]
    dlog_cancel <- button dlog [ text := "Cancel" ]

    varEditor <- entry dlog [ font := fontFixed
                            , text := ""
                            ]
    editor <- entry dlog [ font := fontFixed
                         , text := "0"
                         ]
    descEditor <- entry dlog [ font := fontFixed
                             , text := ""
                             ]
    editorB <- checkBox dlog [ text := "true"
                             , checkable := True
                             , checked := True
                             , visible := False ]

    set editorB [ on command := do
                    isChecked <- get editorB checked
                    set editorB [ text := if isChecked then "true" else "false" ]
                ]
    let colorPickerCtrl :: Window a -> Color -> [Prop (ColourPickerCtrl ())] -> IO (ColourPickerCtrl ())
        colorPickerCtrl parent' color0 props
          = feed2 props 0 $
            initialWindow    $ \iD rect' ps s ->
            do e <- colorPickerCtrlCreate parent' iD color0 rect' s
               set e ps
               return e

    editorC  <- colorPickerCtrl dlog (rgb 255 0 0) [ visible := False ]
    editorC' <- entry dlog [ font := fontFixed
                           , text := "red"
                           , visible := False ]

    let newPick = do
          c <- colorPickerCtrlGetColour editorC
          let cr_ = colorRed   c / 255.0 :: Float
              cg_ = colorGreen c / 255.0 :: Float
              cb_ = colorBlue  c / 255.0 :: Float
          set editorC' [ text := "rgb (" ++ printf "%0.2f" cr_ ++ ", "
                                         ++ printf "%0.2f" cg_ ++ ", "
                                         ++ printf "%0.2f" cb_ ++ ")"
                   ]
    windowOnEvent editorC [wxEVT_COMMAND_COLOURPICKER_CHANGED] newPick (const newPick)

    typeEditor <- choice dlog [ fontFace := "Monaco"
                              , fontSize := 14 ]

    let typeList = ["ℂ", "ℝ", "ℤ", "ℕ", "Boolean", "Color"]
    forM_ typeList (itemAppend typeEditor)

    set dlog
      [ layout := fill $ margin 15 $ column 10 $
        [ row 5 [ boxed "Variable" (hfill $ widget varEditor)
                , column 10 [ label " ", label ":" ]
                , boxed "Type" (widget typeEditor) ]
        , boxed "Default value" $
          column 0 [ hfill (widget editor)
                   , hfill (widget editorB)
                   , row 5 [ widget editorC
                           , hfill (widget editorC') ]
                   ]
        , boxed "Description" (hfill (widget descEditor))
        , row 5 [ widget dlog_ok, hglue, widget dlog_cancel ]
        ]
      ]

    let editParam = do
          mresult <- showModal dlog $ \stopParamEdit -> do
            set typeEditor [ on select := do
                               ix <- get typeEditor selection
                               case ix of
                                 4 -> do
                                   set editor   [ visible := False ]
                                   set editorB  [ visible := True ]
                                   set editorC  [ visible := False ]
                                   set editorC' [ visible := False ]
                                   windowReFit dlog
                                 5 -> do
                                   set editor   [ visible := False ]
                                   set editorB  [ visible := False ]
                                   set editorC  [ visible := True ]
                                   set editorC' [ visible := True ]
                                   windowReFit dlog
                                 _ -> do
                                   set editor   [ visible := True ]
                                   set editorB  [ visible := False ]
                                   set editorC  [ visible := False ]
                                   set editorC' [ visible := False ]
                                   windowReFit dlog
                           ]
            set dlog_ok     [on command := stopParamEdit (Just ())]
            set dlog_cancel [on command := stopParamEdit Nothing]

          case mresult of
            Nothing -> pure Nothing
            Just _ -> do
              vname <- get varEditor text
              vdesc <- get descEditor text
              vtypeIx <- get typeEditor selection
              let vtype = typeList !! vtypeIx
              v <- case vtypeIx of
                4 -> get editorB checked <&> \case { True -> "true"; False -> "false" }
                5 -> get editorC' text
                _ -> get editor text
              pure (Just [vname, v, vtype, vdesc])

    selectedRef <- newIORef Set.empty

    set addParam [ on command := do
                     set varEditor [ text := "" ]
                     set descEditor [ text := "" ]
                     set typeEditor [ selection := 0 ]
                     set editor [ text := "" ]
                     set editorB [ checked := True ]
                     set editorC' [ text := "red" ]
                     editParam >>= \case
                       Nothing -> pure ()
                       Just i  -> listViewAddItem lc i
                 ]

    set delParam [ on command := do
                     sels <- Set.toList <$> readIORef selectedRef
                     case sels of
                       [ix] -> do
                         ct0 <- length <$> listViewGetItems lc
                         putStrLn ("Deleting " ++ show ix ++ ", count was " ++ show ct0)
                         writeIORef selectedRef Set.empty
                         is <- listViewGetItems lc
                         listViewSetItems lc (take ix is ++ drop (ix + 1) is)
                         ct1 <- length <$> listViewGetItems lc
                         putStrLn ("Deleted " ++ show ix ++ ", count was " ++ show ct1)
                       _    -> pure ()
                 ]
    listViewSetHandler lc $ \case
      ListItemSelected ix -> modifyIORef' selectedRef (Set.insert ix)
      ListItemDeselected ix -> modifyIORef' selectedRef (Set.delete ix)
      ListItemFocused ix  -> putStrLn ("focused " ++ show ix )
      ListItemActivated ix -> do
        putStrLn ("activated ix=" ++ show ix)
        [vname, v, vtype, vdesc] <- listViewGetItems lc <&> (!! ix)
        set varEditor [ text := vname ]
        set descEditor [ text := vdesc ]
        let vtypeIx = fromMaybe 0 (lookup vtype (zip typeList [0..]))
        set typeEditor [ selection := vtypeIx ]
        case vtypeIx of
          4 -> set editorB  [ checked := v == "true" ]
          5 -> set editorC' [ text := v ]
          _ -> set editor [text := v]
        editParam >>= \case
          Nothing -> pure ()
          Just i  -> do
            is <- listViewGetItems lc
            listViewSetItems lc (take ix is ++ [i] ++ drop (ix + 1) is)

      ListBeginDrag ix pt _stop -> putStrLn ("drag " ++ show ix ++ ", " ++ show pt)
      _ -> pure ()

    -- Create the menus

    -- File menu
    file <- menuPane      [text := "&File"]
    menuItem file [ text := "&New", on command := putStrLn "TODO"]
--    _    <- menuQuit file [ text := "&Quit"
--                          , help := "Quit FractalStream"]

    -- Help menu
    hlp   <- menuHelp      [ text := "&Help" ]
    menuItem hlp [ text := "blah" ]
    about <- menuAbout hlp [text := "About FractalStream"]

    -- Viewer status bar
    status <- statusField   [text := "Pointer location"]
    toolStatus <- statusField [text := ""]

    -- Tool menu
    tools <- menuPane [text := "&Tool"]
    mapM_ (\(x,y,z) -> menuRadioItem tools [ text := x
                                           , help := y
                                           , on command := do
                                               set toolStatus [text := y]
                                               z])
      [ ("Navigate",
         "Move around a dynamical system, select a point by ctrl-clicking",
         do putStrLn "hi")
      , ("Trace",
         "Follow the orbit of a point",
         do putStrLn "bye")
      ]

    draggedTo <- variable [value := Nothing]
    lastClick <- variable [value := Nothing]
    pendingResize <- variable [value := False]

    -- Panel and tile for initial view
    renderId <- newIORef (0 :: Int)
    viewerTile     <- renderTile' renderId renderAction (width, height) model
    currentTile    <- variable [value := viewerTile]
    savedTileImage <- variable [value := Nothing]
    lastTileImage  <- variable [value := Nothing]

    p <- panel f []

    -- trigger repaint
    let triggerRepaint = do
          repaint p
          windowRefresh p True -- True=redraw background
          windowUpdateWindowUI p

    animate <- variable [value := Nothing]
    let startAnimatingFrom oldModel = do
            now <- getCurrentTime
            img <- get savedTileImage value >>= traverse imageCopy
            set lastTileImage [value := img]
            set animate [value := Just (now, oldModel, img)]

    set p [ on paintRaw := \dc r _dirty -> get animate value >>= \case
                  Nothing -> do
                      -- Normal paint. Draw current rendering, then layer
                      -- tool imagery on top.
                      viewRect <- windowGetViewRect f
                      curTile <- get currentTile value
                      let (w, h) = tileRect curTile
                      get savedTileImage value >>= \case
                          Nothing -> pure ()
                          Just im -> drawCenteredImage im dc viewRect (w, h)
                      paintToolLayer lastClick draggedTo dc r viewRect

                  Just (startTime, oldModel, oldImage) -> do
                      -- Animated paint. Zoom and blend smoothly between
                      -- the new and old images.
                      now <- getCurrentTime
                      let speed :: forall n. Num n => n
                          speed = 6
                          blend = min 255 (round (speed * 255 * toRational (diffUTCTime now startTime)))
                          t = min 1.0 (speed * fromRational (toRational (diffUTCTime now startTime)) :: Double)
                      when (blend >= 255) (set animate [value := Nothing])
                      curTile <- get currentTile value
                      let (w, h) = tileRect curTile

                      gc <- graphicsContextCreate dc
                      newModel <- get model value
                      let midModel = interpolateModel t oldModel newModel
                          withLayer opacity action = do
                              graphicsContextBeginLayer gc opacity
                              action
                              graphicsContextEndLayer gc
                          restoringContext action = do
                              graphicsContextPushState gc
                              action
                              graphicsContextPopState gc

                      let zoom :: (Double, Double) -> (Double, Double) -> IO () -> IO ()
                          zoom (scaleX, scaleY) (cx, cy) action = do
                              restoringContext $ do
                                  graphicsContextTranslate gc cx cy
                                  graphicsContextScale gc (sz scaleX scaleY)
                                  action

                          viewCenterX = fromIntegral w / 2
                          viewCenterY = fromIntegral h / 2
                          dx = (fst (modelCenter newModel) - fst (modelCenter oldModel))
                              / fst (modelPixelDim oldModel)
                          dy = negate (snd (modelCenter newModel) - snd (modelCenter oldModel))
                                     / snd (modelPixelDim oldModel)

                      -- draw the old image
                      let k = 1 / sqrt ( (fst (modelPixelDim oldModel) * snd (modelPixelDim oldModel))
                                   / (fst (modelPixelDim newModel) * snd (modelPixelDim newModel)))
                          t' = if (k - 1)^2 < 0.05 then t else (1 - k ** t) / (1 - k)
                      graphicsContextTranslate gc viewCenterX viewCenterY
                      graphicsContextScale gc (sz (fst (modelPixelDim oldModel)
                                                 / fst (modelPixelDim midModel))
                                                  (snd (modelPixelDim oldModel)
                                                 / snd (modelPixelDim midModel)))
                      graphicsContextTranslate gc (negate viewCenterX) (negate viewCenterY)
                      graphicsContextTranslate gc (negate $ dx * t') (negate $ dy * t')

                      withLayer 1 $ restoringContext $ do
                              zoom (1.0, 1.0)
                                   (viewCenterX, viewCenterY)

                              $ case oldImage of
                                    Nothing -> pure ()
                                    Just im -> drawImage dc im (WX.pt
                                                               (round $ negate viewCenterX)
                                                               (round $ negate viewCenterY)) []
                      -- draw the new image
                      withLayer (min 1 t) $ do
                          let zoomRatioX = fst (modelPixelDim newModel) / fst (modelPixelDim oldModel)
                              zoomRatioY = snd (modelPixelDim newModel) / snd (modelPixelDim oldModel)
                          restoringContext $ do
                              zoom (zoomRatioX, zoomRatioY)
                                   (viewCenterX + dx, viewCenterY + dy)

                                   $ get savedTileImage value >>= \case
                                       Nothing -> pure ()
                                       Just im -> drawImage dc im (WX.pt
                                                                  (round $ negate viewCenterX)
                                                                  (round $ negate viewCenterY)) []
          ]

    let viewToModel pt = do
            Size { sizeW = w, sizeH = h } <- get f clientSize
            let dim = (w,h)
                fullViewRect = rectangle (Viewport (0,0)) (Viewport dim)
            modelRect <- modelToRect @(Double,Double) dim <$> get model value
            pure (convertRect fullViewRect modelRect $ Viewport (pointX pt, pointY pt))

    -- Set click and drag event handlers
    set p [ on mouse   := \case
              MouseLeftDown pt modifiers | isNoShiftAltControlDown modifiers -> do
                set lastClick [value := Just $ Viewport (pointX pt, pointY pt)]
                propagateEvent

              MouseLeftUp pt modifiers | isNoShiftAltControlDown modifiers -> do
                dragBox <- getDragBox lastClick draggedTo
                case dragBox of
                    Nothing  -> do
                        -- Completed a click, recenter to the clicked point.
                        Size { sizeW = w, sizeH = h } <- get f clientSize
                        oldModel <- get model value
                        newCenter <- viewToModel pt
                        set model [value := oldModel
                                    { modelCenter = toCoords newCenter }]

                        get currentTile value >>= cancelTile
                        newViewerTile <- renderTile' renderId renderAction (w, h) model
                        set currentTile [value := newViewerTile]

                        startAnimatingFrom oldModel
                        triggerRepaint
                    Just box -> do
                        -- Completed a drag. Zoom in to the dragged box, unless
                        -- the box is pathologically small; in that case, treat
                        -- the action as if it were a simple click.
                        selectRegion box
                        oldModel <- get model value
                        Size { sizeW = w, sizeH = h } <- get f clientSize
                        newCenter <- viewToModel (viewportToPoint $ rectCenter box)
                        let (px, py) = modelPixelDim oldModel
                            (boxW, boxH) = dimensions box
                            oldArea = fromIntegral (w * h)
                            newArea = boxW * boxH
                            literalScale = sqrt (newArea / oldArea)
                            scale = if literalScale < 0.001 then 1 else literalScale
                        set model [value := oldModel
                                    { modelCenter = toCoords newCenter
                                    , modelPixelDim = (px * scale, py * scale)
                                    }]
                        get currentTile value >>= cancelTile
                        newViewerTile <- renderTile' renderId renderAction (w, h) model
                        set currentTile [value := newViewerTile]
                        startAnimatingFrom oldModel
                        triggerRepaint

                set draggedTo [value := Nothing]
                set lastClick [value := Nothing]
                propagateEvent

              MouseLeftDrag pt modifiers | isNoShiftAltControlDown modifiers -> do
                set draggedTo [value := Just $ Viewport (pointX pt, pointY pt)]
                mpt <- viewToModel pt
                set status [text := show mpt]

                dragBox <- getDragBox lastClick draggedTo
                case dragBox of
                    Nothing -> return ()
                    Just _  -> triggerRepaint

                propagateEvent

              MouseMotion pt modifiers | isNoShiftAltControlDown modifiers -> do
                mpt <- viewToModel pt
                set status [text := show mpt]
                propagateEvent

              -- other mouse events
              _ -> propagateEvent
          ]

    -- Add a timer which will check for repainting requests, ~10Hz
    _ <- timer f [ interval := 100
                 , enabled := True
                 , on command := do
                        curTile <- get currentTile value
                        ifModified curTile $ do
                            viewRect <- windowGetViewRect f
                            tileImage <- generateTileImage curTile viewRect
                            saved <- imageCopy tileImage
                            set savedTileImage [value := Just saved]
                            triggerRepaint
                 ]

    -- Animation timer. At ~65Hz, check if we are animating between
    -- two views. If so, step the animation and repaint.
    _ <- timer f [ interval := 16
                 , enabled := True
                 , on command := get animate value >>= \case
                         Nothing -> pure ()
                         Just _  -> triggerRepaint
                 ]

    -- onResizeTimer is a one-shot timer that fires 100ms after the
    -- frame has been resized. If another resize event comes in during
    -- that interval, the timer is reset to 100ms. When the timer fires,
    -- we kick off a new rendering task to build the contents of the
    -- window. Using a timer lets us avoid starting hundreds of rendering
    -- tasks while the user adjusts their window size.
    onResizeTimer <- timer f [ interval := 100
                             , enabled := False ]
    set onResizeTimer [ on command := do
                              set onResizeTimer [enabled := False] -- one-shot
                              needResize <- get pendingResize value
                              when needResize $ do
                                  set pendingResize [value := False]
                                  Size { sizeW = w0, sizeH = h0 } <- get f clientSize
                                  let w = roundUp w0 16
                                      h = roundUp h0 16
                                      roundUp x n = case x `mod` n of
                                          0 -> x
                                          k -> x + (n - k)
                                  get currentTile value >>= cancelTile
                                  newViewerTile <- renderTile' renderId renderAction (w, h) model
                                  set currentTile [value := newViewerTile]
                                  -- no animation?
                                  triggerRepaint
                      ]

    -- Add the status bar, menu bar, and layout to the frame
    set f [ statusBar := [status, toolStatus]
          , menuBar   := [file,tools,hlp]
          , layout    := fill $ minsize (sz 512 512) $ widget p
          , on resize := do
                  set onResizeTimer [enabled := False]
                  set pendingResize [value := True]
                  set onResizeTimer [enabled := True]
                  propagateEvent
          , on (menu about) :=
              infoDialog f "About FractalStream" $ unlines
              [ "Contributors:"
              , "Matt Noonan"
              ]
          ]

renderTile' :: Valued w
            => IORef Int
            -> (Word32 -> Word32 -> Complex Double -> Complex Double -> Ptr Word8 -> IO ())  --([(Double, Double)] -> IO [Color])
            -> (Int, Int)
            -> w Model
            -> IO Tile
renderTile' renderId action dim model = do
    iD <- atomicModifyIORef' renderId (\x -> (x + 1, x + 1))
    modelRect <- modelToRect dim <$> get model value
    let action' p q x y c = do
            curId <- readIORef renderId
            if (curId == iD) then action p q x y c else pure ()
    renderTile action' dim modelRect

-- | Paint the state of a tile into a device context.
generateTileImage
    :: Tile    -- ^ A tile to convert to an image
    -> Rect    -- ^ The enclosing view rectangle
    -> IO (Image ())

generateTileImage viewerTile _windowRect = do
    let (width, height) = tileRect viewerTile
    --let Point { pointX = fWidth, pointY = fHeight } = rectBottomRight windowRect
    --let (x0, y0) = ( (fWidth  + width ) `div` 2 - width  ,
    --                 (fHeight + height) `div` 2 - height )
    --putStrLn "generateTileImage"
    withSynchedTileBuffer viewerTile (imageCreateFromData (sz width height))

drawCenteredImage :: Image b -> DC d -> Rect -> (Int,Int) -> IO ()

drawCenteredImage img dc windowRect (width, height) = do
    let Point { pointX = fWidth, pointY = fHeight } = rectBottomRight windowRect
    let (x0, y0) = ( (fWidth  + width ) `div` 2 - width  ,
                     (fHeight + height) `div` 2 - height )
    drawImage dc img (WX.pt x0 y0) []

viewportToPoint :: Viewport -> Point
viewportToPoint (Viewport (x,y)) = Point { pointX = x, pointY = y }

paintToolLayer :: Var (Maybe Viewport)
               -> Var (Maybe Viewport)
               -> DC d
               -> Rect
               -> Rect
               -> IO ()
paintToolLayer lastClick draggedTo dc _ _ = dcEncapsulate dc $ do
    dragBox <- getDragBox lastClick draggedTo
    case dragBox of
        Nothing  -> return ()
        Just box -> do
            let boxPts = map viewportToPoint (rectPoints box)
            drawBox dc (rgba 0 128 255 128) white boxPts

getDragBox :: Var (Maybe Viewport)
           -> Var (Maybe Viewport)
           -> IO (Maybe (Rectangle Viewport))
getDragBox lastClick draggedTo = do
    dragSrc <- get lastClick value
    dragTgt <- get draggedTo value
    return $ case (dragSrc, dragTgt) of
        (Just p1, Just p2) -> Just $ rectangle p1 p2
        _                  -> Nothing

drawBox :: DC d
        -> Color
        -> Color
        -> [Point]
        -> IO ()
drawBox dc fillColor lineColor coords =
    polygon dc coords [ brush := brushSolid fillColor
                      , pen := penColored lineColor 2
                      ]

selectRegion :: Rectangle Viewport -> IO ()
selectRegion r = do
    putStrLn $ "selected region " ++ show r
    return ()


-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Statistics.Viterbi.Discrete.Lazy
-- Copyright   :  (c) A. V. H. McPhail 2011
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Viterbi Algorithm
--
-----------------------------------------------------------------------------

module Numeric.Statistics.Viterbi.Discrete.Lazy (
                          ) where

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

import qualified Data.Array.IArray as I

import Numeric.LinearAlgebra

import Numeric.GSL.Statistics

import Numeric.Statistics

import System.Random

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

newtype Viterbi a = Viterbi {
      _memory :: Int
    , _states :: Int

train :: Int       -- ^ sequence length


{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- module Year2021.DayX where
module DayX where

import Util
import Data.Cyclic (Cyclic, Cyclic2)
import qualified Data.Cyclic as Cyclic
import Data.Grid (Grid)
import qualified Data.Grid as Grid

import Numeric
import Numeric.Bool
import Numeric.Char

import GHC.Generics
import GHC.TypeLits as TypeLits

import qualified Linear as Lin
import qualified Linear.V as Lin
import Linear.V2
import Linear.V3
import Linear.V4
import qualified Linear.Matrix as Mat

import Debug.Trace
import Debug.Pretty.Simple

import Text.Regex.PCRE
import Text.Pretty.Simple
import Text.Read (readMaybe)
import qualified Text.Megaparsec as Par
import qualified Text.Megaparsec.Char as Par
import qualified Text.Megaparsec.Char.Lexer as Lex

import qualified Data.SBV as SBV
import qualified Data.SBV.Internals as SBV
import Data.String.Here
import Data.Tuple
import Data.Default
import Data.Proxy
import Data.Void
import Data.Word
import Data.Bits
import Data.Ratio
import Data.Bool
import Data.Bifunctor hiding (first, second)
import Data.Complex
import Data.Foldable
import Data.Char
import Data.Semigroup
import Data.Monoid
import Data.Functor
import Data.Ord
import Data.Function
import Data.Function.Memoize
import Data.Functor.Identity
import Data.Either
import Data.Maybe
import Data.List
import qualified Data.List.Extra as Extra
import Data.List.Split
import qualified Data.Conduit as Cond
import Data.Conduit ((.|))

import Control.Parallel
import Control.Parallel.Strategies
import Control.DeepSeq
import Control.Arrow
import Control.Concurrent
import Control.Lens (_1, _2, _3, _4, _5, _6, _7, _8)
import qualified Control.Lens as Lens
import qualified Numeric.Lens as Lens
import Control.Lens.Operators hiding ((??))
import Control.Applicative
import Control.Monad
import Control.Monad.Extra
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.RWS
import Control.Monad.Except
import Control.Monad.ST
import qualified Control.Monad.Combinators as Comb
import qualified Control.Monad.Combinators.Expr as Comb

import System.FilePath

import Data.Graph.Inductive (Graph, Gr)
import qualified Data.Graph.Inductive as Graph
import Data.List.PointedList (PointedList)
import qualified Data.List.PointedList as PList
import qualified Data.List.PointedList.Circular as PCList
import Data.DList (DList)
import qualified Data.DList as DList
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map.Syntax
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.Sequence (Seq((:<|), (:|>)))
import qualified Data.Sequence as Seq
import Data.Vector.Generic (Vector)
import Data.Vector.Generic.Mutable (MVector)
import qualified Data.Vector as VecB
import qualified Data.Vector.Mutable as VecBM
import qualified Data.Vector.Unboxed as VecU
import qualified Data.Vector.Unboxed.Mutable as VecUM
import qualified Data.Vector.Storable as VecS
import qualified Data.Vector.Storable.Mutable as VecSM
import qualified Data.Vector.Generic as Vec
import qualified Data.Vector.Generic.Mutable as VecM
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Data.PQueue.Prio.Min (MinPQueue)
import qualified Data.Sequence as MinPQ
import Data.PQueue.Prio.Max (MaxPQueue)
import qualified Data.Sequence as MaxPQ

import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

main = do
  input <- readFile (replaceExtension __FILE__ ".in")
  print input


{-# LANGUAGE BangPatterns, RecordWildCards #-}
-- |
-- Module      : Criterion
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Core benchmarking code.

module Criterion.Internal
    (
      runAndAnalyse
    , runAndAnalyseOne
    , runOne
    , runFixedIters
    ) where

import qualified Data.Aeson as Aeson
import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Control.Monad (foldM, forM_, void, when, unless)
import Control.Monad.Catch (MonadMask, finally)
import Control.Monad.Reader (ask, asks)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Except
import qualified Data.Binary as Binary
import Data.Int (Int64)
import qualified Data.ByteString.Lazy.Char8 as L
import Criterion.Analysis (analyseSample, noteOutliers, analyseSimpleSample)
import Criterion.IO (header, headerRoot, critVersion, readJSONReports, writeJSONReports)
import Criterion.IO.Printf (note, printError, prolix, writeCsv)
import Criterion.Measurement (runBenchmark, runBenchmarkable_, secs)
import Criterion.Measurement.Types (hasFixedIters)
import Criterion.Monad (Criterion)
import Criterion.Report (report)
import Criterion.Types hiding (measure)
import Criterion.Measurement.Types.Internal (fakeEnvironment)
import qualified Data.Map as Map
import qualified Data.Vector as V
import Statistics.Types (Estimate(..),ConfInt(..),confidenceInterval,cl95,confidenceLevel)
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (IOMode(..), hClose, openTempFile, openFile, hPutStr, openBinaryFile)
import Text.Printf (printf)

-- | Run a single benchmark.
runOne :: Int -> String -> Benchmarkable -> Criterion DataRecord
runOne i desc bm = do
  Config{..} <- ask
  (meas,timeTaken) <- liftIO $ runBenchmark bm timeLimit
  when (timeTaken > timeLimit * 1.25) .
    void $ prolix "measurement took %s\n" (secs timeTaken)
  return (Measurement i desc meas)

-- | Analyse a single benchmark.
analyseOne :: Int -> Bool -> String -> V.Vector Measured -> Criterion DataRecord
analyseOne i simple desc meas = do
  Config{..} <- ask
  _ <- prolix "analysing with %d resamples\n" resamples
  erp <- runExceptT $ if simple
    then analyseSimpleSample i desc meas
    else analyseSample i desc meas
  case erp of
    Left err -> printError "*** Error: %s\n" err
    Right rpt@Report{..} -> do
      let SampleAnalysis{..} = reportAnalysis
          OutlierVariance{..} = anOutlierVar
          wibble = case ovEffect of
                     Unaffected -> "unaffected" :: String
                     Slight -> "slightly inflated"
                     Moderate -> "moderately inflated"
                     Severe -> "severely inflated"
          (builtin, others) = splitAt 1 anRegress
      let r2 n = printf "%.3f R\178" n
      forM_ builtin $ \Regression{..} ->
        case Map.lookup "iters" regCoeffs of
          Nothing -> return ()
          Just t  -> bs secs "time" t >> bs r2 "" regRSquare
      bs secs "mean" anMean
      bs secs "std dev" anStdDev
      forM_ others $ \Regression{..} -> do
        _ <- bs r2 (regResponder ++ ":") regRSquare
        forM_ (Map.toList regCoeffs) $ \(prd,val) ->
          bs (printf "%.3g") ("  " ++ prd) val
      writeCsv
        (desc,
         estPoint anMean,   fst $ confidenceInterval anMean,   snd $ confidenceInterval anMean,
         estPoint anStdDev, fst $ confidenceInterval anStdDev, snd $ confidenceInterval anStdDev
        )
      when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do
        when (verbosity == Verbose) $ noteOutliers reportOutliers
        _ <- note "variance introduced by outliers: %d%% (%s)\n"
             (round (ovFraction * 100) :: Int) wibble
        return ()
      _ <- note "\n"
      return (Analysed rpt)
      where bs :: (Double -> String) -> String -> Estimate ConfInt Double -> Criterion ()
            bs f metric e@Estimate{..} =
              note "%-20s %-10s (%s .. %s%s)\n" metric
                   (f estPoint) (f $ fst $ confidenceInterval e) (f $ snd $ confidenceInterval e)
                   (let cl = confIntCL estError
                        str | cl == cl95 = ""
                            | otherwise  = printf ", ci %.3f" (confidenceLevel cl)
                    in str
                   )

{-}
analyseOneSimple :: Int -> String -> V.Vector Measured
                 -> Criterion ()
analyseOneSimple i desc meas = do
    erp <- runExceptT $ analyseSimpleSample i desc meas
    case erp of
      Left err -> printError "*** Error: %s\n" err
      Right (stMean, stDev) -> do
        bs secs "mean" stMean
        bs secs "std dev" stDev
  where
    bs :: (Double -> String) -> String -> Estimate ConfInt Double -> Criterion ()
    bs f metric e@Estimate{..} =
      note "%-20s %-10s (%s .. %s%s)\n" metric
           (f estPoint) (f $ fst $ confidenceInterval e) (f $ snd $ confidenceInterval e)
           (let cl = confIntCL estError
                str | cl == cl95 = ""
                    | otherwise  = printf ", ci %.3f" (confidenceLevel cl)
            in str
           )
-}

-- | Run a single benchmark and analyse its performance.
runAndAnalyseOne :: Int -> String -> Benchmarkable -> Criterion DataRecord
runAndAnalyseOne i desc bm = do
  Measurement _ _ meas <- runOne i desc bm
  analyseOne i (hasFixedIters bm) desc meas

-- | Run, and analyse, one or more benchmarks.
runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses
                                  -- whether to run a benchmark by its
                                  -- name.
              -> Benchmark
              -> Criterion ()
runAndAnalyse select bs = do
  mbJsonFile <- asks jsonFile
  (jsonFile, handle) <- liftIO $
    case mbJsonFile of
      Nothing -> do
        tmpDir <- getTemporaryDirectory
        openTempFile tmpDir "criterion.json"
      Just file -> do
        handle <- openFile file WriteMode
        return (file, handle)
  -- The type we write to the file is ReportFileContents, a triple.
  -- But here we ASSUME that the tuple will become a JSON array.
  -- This assumption lets us stream the reports to the file incrementally:
  liftIO $ hPutStr handle $ "[ \"" ++ headerRoot ++ "\", " ++
                             "\"" ++ critVersion ++ "\", [ "

  for select bs $ \idx desc bm -> do
    _ <- note "benchmarking %s\n" desc
    Analysed rpt <- runAndAnalyseOne idx desc bm
    unless (idx == 0) $
      liftIO $ hPutStr handle ", "
    liftIO $ L.hPut handle (Aeson.encode (rpt::Report))

{-}
  for select bs $ \idx desc bm -> do
    _ <- note "benchmarking %s\n" desc
    if (hasFixedIters bm)
    then do
      measur <- runAndAnalyseOne idx desc bm
      liftIO $ print measur
    else do
      Analysed rpt <- runAndAnalyseOne idx desc bm
      unless (idx == 0) $
        liftIO $ hPutStr handle ", "
      liftIO $ L.hPut handle (Aeson.encode (rpt::Report))
-}
  liftIO $ hPutStr handle " ] ]\n"
  liftIO $ hClose handle

  rpts <- liftIO $ do
    res <- readJSONReports jsonFile
    case res of
      Left err -> error $ "error reading file "++jsonFile++":\n  "++show err
      Right (_,_,rs) ->
       case mbJsonFile of
         Just _ -> return rs
         _      -> removeFile jsonFile >> return rs

  rawReport rpts
  report rpts
  json rpts
  junit rpts

-- | Write out raw binary report files.  This has some bugs, including and not
-- limited to #68, and may be slated for deprecation.
rawReport :: [Report] -> Criterion ()
rawReport reports = do
  mbRawFile <- asks rawDataFile
  case mbRawFile of
    Nothing   -> return ()
    Just file -> liftIO $ do
      handle <- openBinaryFile file ReadWriteMode
      L.hPut handle header
      forM_ reports $ \rpt ->
        L.hPut handle (Binary.encode rpt)
      hClose handle

-- | Run a benchmark without analysing its performance.
runFixedIters :: Int64            -- ^ Number of loop iterations to run.
              -> (String -> Bool) -- ^ A predicate that chooses
                                  -- whether to run a benchmark by its
                                  -- name.
              -> Benchmark
              -> Criterion ()
runFixedIters iters select bs =
  for select bs $ \_idx desc bm -> do
    _ <- note "benchmarking %s\n" desc
    liftIO $ runBenchmarkable_ bm iters

-- | Iterate over benchmarks.
for :: (MonadMask m, MonadIO m) => (String -> Bool) -> Benchmark
    -> (Int -> String -> Benchmarkable -> m ()) -> m ()
for select bs0 handle = go (0::Int) ("", bs0) >> return ()
  where
    go !idx (pfx, Environment mkenv cleanenv mkbench)
      | shouldRun pfx mkbench = do
        e <- liftIO $ do
          ee <- mkenv
          evaluate (rnf ee)
          return ee
        go idx (pfx, mkbench e) `finally` liftIO (cleanenv e)
      | otherwise = return idx
    go idx (pfx, Benchmark desc b)
      | select desc' = do handle idx desc' b; return $! idx + 1
      | otherwise    = return idx
      where desc' = addPrefix pfx desc
    go idx (pfx, BenchGroup desc bs) =
      foldM go idx [(addPrefix pfx desc, b) | b <- bs]

    shouldRun pfx mkbench =
      any (select . addPrefix pfx) . benchNames . mkbench $ fakeEnvironment

-- | Write summary JSON file (if applicable)
json :: [Report] -> Criterion ()
json rs
  = do jsonOpt <- asks jsonFile
       case jsonOpt of
         Just fn -> liftIO $ writeJSONReports fn rs
         Nothing -> return ()

-- | Write summary JUnit file (if applicable)
junit :: [Report] -> Criterion ()
junit rs
  = do junitOpt <- asks junitFile
       case junitOpt of
         Just fn -> liftIO $ writeFile fn msg
         Nothing -> return ()
  where
    msg = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
          printf "<testsuite name=\"Criterion benchmarks\" tests=\"%d\">\n"
          (length rs) ++
          concatMap single rs ++
          "</testsuite>\n"
    single Report{..} = printf "  <testcase name=\"%s\" time=\"%f\" />\n"
               (attrEsc reportName) (estPoint $ anMean $ reportAnalysis)
    attrEsc = concatMap esc
      where
        esc '\'' = "'"
        esc '"'  = """
        esc '<'  = "<"
        esc '>'  = ">"
        esc '&'  = "&"
        esc c    = [c]


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Arpack.Foreign.Real () where

import qualified Control.Concurrent.Lock as Lock
import Control.Exception (bracket, throwIO)
import Data.Maybe (fromMaybe)
import qualified Data.Vector.Storable as VS
import Data.Vector.Storable.Mutable (IOVector)
import qualified Data.Vector.Storable.Mutable as VSM
import Foreign
import Foreign.C.String
import Foreign.C.Types (CChar)
import Foreign.Storable.Complex ()
import qualified Numeric.LinearAlgebra.Devel as Dense

import Arpack.Exceptions
import Arpack.Foreign.Class
import qualified Arpack.Lock as Arpack
import Arpack.Options

--
-- * Foreign functions
--

foreign import ccall unsafe "dnaupd_"
  dnaupd_ :: Ptr Int32  -- ido
          -> Ptr CChar  -- bmat
          -> Ptr Int32  -- n
          -> Ptr CChar  -- which
          -> Ptr Int32  -- nev
          -> Ptr Double -- tol
          -> Ptr Double -- resid
          -> Ptr Int32  -- ncv
          -> Ptr Double -- v
          -> Ptr Int32  -- ldv
          -> Ptr Int32  -- iparam
          -> Ptr Int32  -- ipntr
          -> Ptr Double -- workd
          -> Ptr Double -- workl
          -> Ptr Int32  -- lworkl
          -> Ptr Int32  -- info
          -> IO ()

foreign import ccall unsafe "dneupd_"
  dneupd_ :: Ptr Int32  -- rvec
          -> Ptr CChar  -- howmny
          -> Ptr Int32  -- select
          -> Ptr Double -- dr
          -> Ptr Double -- di
          -> Ptr Double -- z
          -> Ptr Int32  -- ldz
          -> Ptr Double -- sigmar
          -> Ptr Double -- sigmai
          -> Ptr Double -- workev
          -> CString    -- bmat
          -> Ptr Int32  -- n
          -> Ptr CChar  -- which
          -> Ptr Int32  -- nev
          -> Ptr Double -- tol
          -> Ptr Double -- resid
          -> Ptr Int32  -- ncv
          -> Ptr Double -- v
          -> Ptr Int32  -- ldv
          -> Ptr Int32  -- iparam
          -> Ptr Int32  -- ipntr
          -> Ptr Double -- workd
          -> Ptr Double -- workl
          -> Ptr Int32  -- lworkl
          -> Ptr Int32  -- info
          -> IO ()

--
-- * Types
--

data AUPD
  = AUPD
    { ido :: {-# UNPACK #-} !(Ptr Int32)
    , bmat :: {-# UNPACK #-} !(Ptr CChar)
    , n :: {-# UNPACK #-} !(Ptr Int32)
    , which :: {-# UNPACK #-} !(Ptr CChar)
    , nev :: {-# UNPACK #-} !(Ptr Int32)
    , tol :: {-# UNPACK #-} !(Ptr Double)
    , resid :: {-# UNPACK #-} !(IOVector Double)
    , ncv :: {-# UNPACK #-} !(Ptr Int32)
    , v :: {-# UNPACK #-} !(IOVector Double)
    , ldv :: {-# UNPACK #-} !(Ptr Int32)
    , iparam :: {-# UNPACK #-} !(IOVector Int32)
    , ipntr :: {-# UNPACK #-} !(IOVector Int32)
    , workd :: {-# UNPACK #-} !(IOVector Double)
    , workl :: {-# UNPACK #-} !(IOVector Double)
    , lworkl :: {-# UNPACK #-} !(Ptr Int32)
    , info :: {-# UNPACK #-} !(Ptr Int32)
    }

withAUPD :: Options Double -> Int -> (AUPD -> IO a) -> IO a
withAUPD options dim = bracket initAUPD freeAUPD where

  initAUPD = do
    let
      _nev = number options

      -- Largest number of basis vectors to use.
      -- Work per iteration is O(dim * ncv ^ 2).

      _ncv = min dim (4 * _nev)

      _lworkl = 3 * _ncv * _ncv + 6 * _ncv

    ido <- new 0
    bmat <- newCString "I"
    n <- new (fromIntegral dim)
    which <- newCString "SR"
    nev <- new (fromIntegral _nev)
    tol <- new 0
    resid <- VSM.new dim
    ncv <- new (fromIntegral _ncv)
    v <- VSM.new (dim * _ncv)
    ldv <- new (fromIntegral dim)

    iparam <- VSM.new 11
    -- shift strategy
    VSM.write iparam (1 - 1) 1
    -- maximum number of iterations
    VSM.write iparam (3 - 1)
      (fromIntegral (fromMaybe (3 * dim) (maxIterations options)))
    -- block size
    VSM.write iparam (4 - 1) 1
    -- eigenproblem type
    VSM.write iparam (7 - 1) 1

    ipntr <- VSM.new 14
    workd <- VSM.new (3 * dim)
    workl <- VSM.new _lworkl
    lworkl <- new (fromIntegral _lworkl)
    info <- new 0

    pure AUPD {..}

  freeAUPD AUPD {..} = do
    free ido
    free bmat
    free n
    free which
    free nev
    free tol
    free ncv
    free ldv
    free lworkl
    free info

data EUPD
  = EUPD
    { rvec :: {-# UNPACK #-} !(Ptr Int32)
    , howmny :: {-# UNPACK #-} !(Ptr CChar)
    , select :: {-# UNPACK #-} !(IOVector Int32)
    , dr :: {-# UNPACK #-} !(IOVector Double)
    , di :: {-# UNPACK #-} !(IOVector Double)
    , z :: {-# UNPACK #-} !(IOVector Double)
    , ldz :: {-# UNPACK #-} !(Ptr Int32)
    , sigmar :: {-# UNPACK #-} !(Ptr Double)
    , sigmai :: {-# UNPACK #-} !(Ptr Double)
    , workev :: {-# UNPACK #-} !(IOVector Double)
    }

withEUPD :: AUPD -> (EUPD -> IO a) -> IO a
withEUPD (AUPD {..}) = bracket initEUPD freeEUPD where

  initEUPD = do
    _nev <- fromIntegral <$> peek nev
    _ncv <- fromIntegral <$> peek ncv
    dim <- fromIntegral <$> peek n

    rvec <- new 1
    howmny <- newCString "A"
    select <- VSM.new _ncv
    dr <- VSM.new (_nev + 1)
    di <- VSM.new (_nev + 1)
    z <- VSM.new (dim * _nev)
    ldz <- new (fromIntegral dim)
    sigmar <- malloc
    sigmai <- malloc
    workev <- VSM.new (2 * _ncv)
    pure EUPD {..}

  freeEUPD (EUPD {..}) = do
    free rvec
    free howmny
    free ldz
    free sigmar
    free sigmai

--
-- * Wrappers
--

aupd :: AUPD -> IO ()
aupd (AUPD {..}) =
  VSM.unsafeWith resid $ \_resid ->
  VSM.unsafeWith v $ \_v ->
  VSM.unsafeWith iparam $ \_iparam ->
  VSM.unsafeWith ipntr $ \_ipntr ->
  VSM.unsafeWith workd $ \_workd ->
  VSM.unsafeWith workl $ \_workl ->

  dnaupd_ ido bmat n which nev tol _resid ncv _v ldv
          _iparam _ipntr _workd _workl lworkl info

eupd :: EUPD -> AUPD -> IO ()
eupd (EUPD {..}) (AUPD {..}) =
  VSM.unsafeWith select $ \_select ->
  VSM.unsafeWith dr $ \_dr ->
  VSM.unsafeWith di $ \_di ->
  VSM.unsafeWith z $ \_z ->
  VSM.unsafeWith workev $ \_workev ->
  VSM.unsafeWith resid $ \_resid ->
  VSM.unsafeWith v $ \_v ->
  VSM.unsafeWith iparam $ \_iparam ->
  VSM.unsafeWith ipntr $ \_ipntr ->
  VSM.unsafeWith workd $ \_workd ->
  VSM.unsafeWith workl $ \_workl ->

  dneupd_ rvec howmny _select _dr _di _z ldz sigmar sigmai _workev
          bmat n which nev tol _resid ncv _v ldv _iparam _ipntr
          _workd _workl lworkl info

instance Arpack Double where

  arpack !opts !dim !multiply
    -- These variables are all banged because we need to be strict
    -- in them _before_ we enter the locked segment of code! If we
    -- wait until we're inside the lock, and evaluating one of these
    -- variables invokes 'arpack' again, the program will deadlock!
    = withAUPD opts dim $ \stateA@(AUPD {..}) -> do

      let
        loop = do
          aupd stateA
          peek ido >>= \case
            99 -> do
              peek info >>= \case
                0 -> pure ()
                1 -> throwIO MaxIterations
                3 -> throwIO NoShifts
                i -> throwIO (XYAUPD i)

            i | abs i == 1 -> do
                  xi <- fromIntegral <$> VSM.read ipntr 0
                  let
                    x = VSM.slice (xi - 1) dim workd
                  yi <- fromIntegral <$> VSM.read ipntr 1
                  let
                    y = VSM.slice (yi - 1) dim workd
                  multiply y x
                  loop

              | otherwise -> throwIO (Unimplemented i)

        extract = withEUPD stateA $ \stateE@(EUPD {..}) -> do
          eupd stateE stateA

          peek info >>= \case
            0 -> pure ()
            1 -> throwIO Reallocate
            i -> throwIO (XYEUPD i)

          evals <- VS.unsafeFreeze (VSM.slice 0 (number opts) dr)
          evecs <- VS.unsafeFreeze (VSM.slice 0 (number opts * dim) z)
          let matrixFromVector = Dense.matrixFromVector Dense.ColumnMajor
          pure (evals, matrixFromVector dim (number opts) evecs)

      Lock.with Arpack.lock (loop >> extract)


{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
module Releaser.SettingsRouting
    ( routing
    , bnNbn
    , mapProductType
    , productTypes
    , ConfigRouting (..)
    , ConfigProcTimes (..)
    , queues
    , isRoutedOver'
    , machines
    , allBlocks
    , procTimes
    , procTimesConst
    ) where

import           Control.Arrow                       (second)
import           Data.List                           (nub, sort)
import           Data.Text                           (Text)
import           Prelude
import           SimSim                              hiding (allBlocks, productTypes,
                                                      queues)
import           Statistics.Distribution
import           Statistics.Distribution.Exponential
import           Statistics.Distribution.Uniform
import           System.Random.MWC

import           Releaser.Routing.Ops
import           Releaser.Routing.Type

routing :: ConfigRouting
routing =
  -- routingSingleStageSingleProduct
  -- routingSingleStage
  -- routingDiverging2Stages
  routingDiverging3Stages

procTimes :: ConfigProcTimes
procTimes =
  -- procTimesDiverging2Stages
  -- procTimesDiverging3StagesUnif
  procTimesDiverging3StagesExp

productTypes :: [ProductType]
productTypes = sort $ nub $ map (fst . fst) (configRoutingRoutes routing)

isRoutedOver' :: Block -> ProductType -> Bool
isRoutedOver' bl pt = isRoutedOver (configRoutingRoutes routing) pt bl

bnNbn :: Bool
bnNbn = False -- True

mapProductType :: ProductType -> ProductType
mapProductType x | not bnNbn = x
mapProductType (Product 1) = Product 1
mapProductType (Product 2) = Product 2
mapProductType (Product 3) = Product 1
mapProductType (Product 4) = Product 1
mapProductType (Product 5) = Product 2
mapProductType (Product 6) = Product 1
mapProductType _ = error "function mapProductType not complete in SettingsRouting"

allBlocks :: [Block]
allBlocks = nub $ map (snd . fst) (configRoutingRoutes routing)

queues :: [Block]
queues = filter isQueue allBlocks

machines :: [Block]
machines = filter isMachine allBlocks

--

data ConfigProcTimes = ConfigProcTimes
  { configProcTimesName :: !Text
  , configProcTimes     :: !ProcTimes
  }

test :: IO ()
test = do
  let mkTime = timeFromDouble <$> withSystemRandom (asGenIO $ genContVar (exponential (960 / 80)))
      nr = 10000
  ts <- mapM (const mkTime ) [1..nr]

  print (sum ts / fromIntegral nr)

procTimesDiverging3StagesExp :: ConfigProcTimes
procTimesDiverging3StagesExp = ConfigProcTimes "Proc Times diverging 3 stages: Exp" $
  map (second $ filter ((`elem` productTypes) . fst)) $ filter ((`elem` allBlocks) . fst)
  [ (Machine 1, forAllProducts (fmap timeFromDouble . genContVar (exponential (960  / 80))))
  , (Machine 2, forAllProducts (fmap timeFromDouble . genContVar (exponential (960 / 160))))
  , (Machine 3, forAllProducts (fmap timeFromDouble . genContVar (exponential (960 / 155))))
  , (Machine 4, forAllProducts (fmap timeFromDouble . genContVar (exponential (960 / 210))))
  , (Machine 5, forAllProducts (fmap timeFromDouble . genContVar (exponential (960 / 285))))
  , (Machine 6, forAllProducts (fmap timeFromDouble . genContVar (exponential (960 / 215))))
  ]

  where forAllProducts x = map (,x) productTypes

procTimesDiverging3StagesUnif :: ConfigProcTimes
procTimesDiverging3StagesUnif = ConfigProcTimes "Proc Times diverging 3 stages: Unif" $
  map (second $ filter ((`elem` productTypes) . fst)) $ filter ((`elem` allBlocks) . fst)
  [ (Machine 1, forAllProducts (fmap timeFromDouble . genContVar (uniformDistr (30 / 960) (130 / 960))))
  , (Machine 2, forAllProducts (fmap timeFromDouble . genContVar (uniformDistr (80 / 960) (240 / 960))))
  , (Machine 3, forAllProducts (fmap timeFromDouble . genContVar (uniformDistr (50 / 960) (260 / 960))))
  , (Machine 4, forAllProducts (fmap timeFromDouble . genContVar (uniformDistr (50 / 960) (370 / 960))))
  , (Machine 5, forAllProducts (fmap timeFromDouble . genContVar (uniformDistr (200 / 960) (370 / 960))))
  , (Machine 6, forAllProducts (fmap timeFromDouble . genContVar (uniformDistr (110 / 960) (320 / 960))))
  ]

  where forAllProducts x = map (,x) productTypes

procTimesDiverging2Stages :: ConfigProcTimes
procTimesDiverging2Stages = ConfigProcTimes "Proc Times diverging 2 stages: Unif" $
  map (second $ filter ((`elem` productTypes) . fst)) $ filter ((`elem` allBlocks) . fst)
  [ (Machine 1, [ (Product 1, fmap timeFromDouble . genContVar (uniformDistr (70 / 960) (130 / 960)))
                , (Product 2, fmap timeFromDouble . genContVar (uniformDistr (70 / 960) (130 / 960)))])
  , (Machine 2, [(Product 1, fmap timeFromDouble . genContVar (uniformDistr (130 / 960) (170 / 960)))])
  , (Machine 3, [(Product 2, fmap timeFromDouble . genContVar (uniformDistr (180 / 960) (200 / 960)))])
  ]

procTimesConst :: ConfigProcTimes
procTimesConst = ConfigProcTimes "Proc Times diverging 2 stages: Const" $
  map (second $ filter ((`elem` productTypes) . fst)) $ filter ((`elem` allBlocks) . fst)
    [ (Machine 1, [(Product 1, return . const (timeFromDouble (100 / 960))), (Product 2, return . const (timeFromDouble (100 / 960)))])
    , (Machine 2, [(Product 1, return . const (timeFromDouble (150 / 960)))])
    , (Machine 3, [(Product 2, return . const (timeFromDouble (190 / 960)))])
    ]


{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}

module School.Unit.UnitGradient
( UnitGradient(..)
, isGradientFail
) where

import Numeric.LinearAlgebra (Container, Matrix, Vector)

data UnitGradient a =
   BatchGradient (Matrix a)
 | GradientFail String deriving (Show)

instance (Container Vector a, Num a, Eq a) => Eq (UnitGradient a) where
  (BatchGradient g1) == (BatchGradient g2) =
    g1 == g2
  (GradientFail _) == (GradientFail _) = True
  _ == _ = False

isGradientFail :: UnitGradient a -> Bool
isGradientFail (GradientFail _) = True
isGradientFail _ = False