content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE DerivingVia #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE StandaloneDeriving #-}
  
  -- base
  import qualified Control.Arrow as Arrow
  
  import Data.Data
  
  import Prelude hiding (Bounded)
  
  -- transformers
  import Control.Monad.Trans.Accum
  
  import Control.Monad.Trans.Class
  import Control.Monad.Trans.Reader (ask)
  import Control.Monad.Trans.State.Strict (StateT)
  import Control.Monad.Trans.Writer.Strict
  
  -- syb
  import Data.Generics.Aliases (ext2Q)
  
  -- gloss
  import Graphics.Gloss hiding (translate)
  import qualified Graphics.Gloss as Gloss
  
  -- essence-of-live-coding
  import LiveCoding hiding (left, right)
  
  -- essence-of-live-coding-gloss
  import LiveCoding.Gloss hiding (every, statePicture, translate)
  
  main :: IO ()
  main = liveMain liveProgram
  
  liveProgram :: LiveProgram (HandlingStateT IO)
  liveProgram = liveCell $ glossWrapC defaultSettings {debugEvents = True} glossCell >>> arr (const ())
  
  glossCell' :: Cell PictureM () ()
  glossCell' =
    speed
      >>> integrate
      >>> arr sin
      >>> arr (* 10)
      >>> arr realToFrac
      >>> arr circleThing
      >>> addPicture
    where
      circleThing x =
        (Gloss.translate (x * 10 - 90) 0 $ color green $ thickCircle 10 20)
          <> (Gloss.translate (-x * 10 - 90) (-40) $ color red $ thickCircle 10 20)
  
  speed :: Cell PictureM () Float
  speed = proc () -> do
    events <- arrM (const ask) -< ()
    sumC -< sum $ isEventMouseClick <$> events
  
  isEventMouseClick :: Event -> Float
  isEventMouseClick (EventKey (MouseButton LeftButton) _ _ _) = 1
  isEventMouseClick (EventKey (MouseButton RightButton) _ _ _) = -1
  isEventMouseClick _ = 0
  
  glossCell :: Cell PictureM () ()
  glossCell = withDebuggerC glossCell' glossDebugger
  
  -- * To be ported to essence-of-live-coding-gloss (and delete the Arrows)
  
  statePicture :: (Data s) => s -> Picture
  statePicture = Gloss.translate (-100) 100 . scale 0.1 0.1 . color red . getPic . stateBoundedPic
  
  stateBoundedPic :: (Data s) => s -> BoundedPic
  stateBoundedPic =
    (boundPic . text . stateShow)
      `ext2Q` compPic
  
  data Bounds = Bounds
    { left :: Float
    , right :: Float
    , bottom :: Float
    , top :: Float
    }
  
  instance Semigroup Bounds where
    bounds1 <> bounds2 =
      Bounds
        { left = min (left bounds1) (left bounds2)
        , right = max (right bounds1) (right bounds2)
        , bottom = min (bottom bounds1) (bottom bounds2)
        , top = max (top bounds1) (top bounds2)
        }
  
  instance Monoid Bounds where
    mempty = boundPoint (0, 0)
  
  boundPoint :: Point -> Bounds
  boundPoint (x, y) = Bounds x x y y
  
  boundPath :: Path -> Bounds
  boundPath path = mconcat $ boundPoint <$> path
  
  pad :: Float -> Bounds -> Bounds
  pad padding Bounds {..} =
    Bounds
      { left = left - padding
      , right = right + padding
      , bottom = bottom - padding
      , top = top + padding
      }
  
  translateBounds :: Point -> Bounds -> Bounds
  translateBounds (x, y) Bounds {..} =
    Bounds
      { left = left + x
      , right = right + x
      , bottom = bottom + y
      , top = top + y
      }
  
  scaleBounds :: Float -> Float -> Bounds -> Bounds
  scaleBounds x y Bounds {..} =
    Bounds
      { left = left * x
      , right = right * x
      , bottom = bottom * y
      , top = top * y
      }
  
  type Bounded a = Accum Bounds a
  
  type BoundedPic = Bounded Picture
  
  -- deriving via Ap Bounded Picture instance Monoid BoundedPic
  
  getBounds :: BoundedPic -> Bounds
  getBounds = flip execAccum mempty
  
  getPic :: BoundedPic -> Picture
  getPic = flip evalAccum mempty
  
  transformBounds :: (Bounds -> Bounds) -> BoundedPic -> BoundedPic
  transformBounds f = mapAccumT $ fmap $ Arrow.second f
  
  transformPic :: (Picture -> Picture) -> BoundedPic -> BoundedPic
  transformPic = fmap
  
  translate :: Float -> Float -> BoundedPic -> BoundedPic
  translate x y = transformBounds (translateBounds (x, y)) . transformPic (Gloss.translate x y)
  
  bounds :: Picture -> Bounds
  bounds Blank = mempty
  bounds (Polygon path) = boundPath path
  bounds (Line path) = boundPath path
  bounds (Circle r) = Bounds r r r r
  bounds (ThickCircle _ r) = Bounds r r r r
  bounds (Arc _ _ r) = Bounds r r r r -- TODO Not the tightest bound
  bounds (ThickArc _ _ _ r) = Bounds r r r r -- TODO Not the tightest bound
  bounds (Text s) = Bounds 0 (fromIntegral $ length s * 105) (-33.3) (120) -- TODO Only rough estimates from https://hackage.haskell.org/package/GLUT-2.7.0.12/docs/Graphics-UI-GLUT-Fonts.html
  bounds (Bitmap bitmapData) = let (right, top) = bitmapSize bitmapData in Bounds 0 (fromIntegral right) 0 (fromIntegral top) -- TODO Untested
  bounds (BitmapSection _ bitmapData) = let (right, top) = bitmapSize bitmapData in Bounds 0 (fromIntegral right) 0 (fromIntegral top) -- TODO Untested
  bounds (Color _ pic) = bounds pic
  bounds (Translate x y pic) = translateBounds (x, y) $ bounds pic
  bounds (Rotate angle pic) = error "Too hard right now" -- TODO
  bounds (Scale x y pic) = scaleBounds x y $ bounds pic
  bounds (Pictures pics) = mconcat $ bounds <$> pics
  
  boundPic :: Picture -> BoundedPic
  boundPic picture = accum $ const (picture, bounds picture)
  
  resetLeft :: BoundedPic -> BoundedPic
  resetLeft boundedPic = translate (-(left $ getBounds boundedPic)) 0 boundedPic
  
  distance = 5
  
  addRight :: BoundedPic -> BoundedPic -> BoundedPic
  addRight bpic1 bpic2 = do
    pic1 <- bpic1
    x <- looks right
    pic2 <- translate (x + distance) 0 $ resetLeft bpic2
    return $ pic1 <> pic2
  
  center :: BoundedPic -> BoundedPic
  center boundPic = let Bounds {..} = getBounds boundPic in translate (left + right) (bottom + top) boundPic
  
  compPic :: (Data s1, Data s2) => Composition s1 s2 -> BoundedPic
  compPic Composition {..}
    | isUnit state1 = stateBoundedPic state2
    | isUnit state2 = stateBoundedPic state1
    | otherwise = stateBoundedPic state1 `addRight` stateBoundedPic state2
  
  glossDebugger :: Debugger PictureM
  glossDebugger = Debugger $ liveCell $ every 100 >>> hold blank >>> arrM (lift . lift . tell)
  
  every :: (Data s) => Integer -> Cell (StateT s PictureM) () (Maybe Picture)
  every maxN = proc () -> do
    n <- sumC -< 1
    if n `mod` maxN == 0
      then do
        s <- getC -< ()
        let pic = statePicture s
        returnA -< Just pic
      else returnA -< Nothing
  