essence-of-live-coding-gloss-example (empty) → 0.2.1

raw patch · 5 files changed

+285/−0 lines, 5 filesdep +basedep +essence-of-live-codingdep +essence-of-live-coding-glosssetup-changed

Dependencies added: base, essence-of-live-coding, essence-of-live-coding-gloss, gloss, syb, transformers

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
app/Main.hs +199/−0
essence-of-live-coding-gloss-example.cabal +49/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for essence-of-live-coding-gloss-example++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2019, Manuel Bärenz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Manuel Bärenz nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,199 @@+{-# 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 (statePicture, every, translate)++main :: IO ()+main = runHandlingStateT $ foreground liveProgram++liveProgram :: LiveProgram (HandlingStateT IO)+liveProgram = liveCell $ glossWrapC defaultSettings { debugEvents = True } glossCell++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 (s1, s2))+  | isUnit s1 = stateBoundedPic s2+  | isUnit s2 = stateBoundedPic s1+  | otherwise = stateBoundedPic s1 `addRight` stateBoundedPic s2++glossDebugger :: Debugger PictureM+glossDebugger = Debugger $ liveCell $ every 100 >>> keep 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

+ essence-of-live-coding-gloss-example.cabal view

@@ -0,0 +1,49 @@+name:                essence-of-live-coding-gloss-example+version:             0.2.1+synopsis: General purpose live coding framework - Gloss example+description:+  essence-of-live-coding is a general purpose and type safe live coding framework.+  .+  You can run programs in it, and edit, recompile and reload them while they're running.+  Internally, the state of the live program is automatically migrated when performing hot code swap.+  .+  The library also offers an easy to use FRP interface.+  It is parametrized by its side effects,+  separates data flow cleanly from control flow,+  and allows to develop live programs from reusable, modular components.+  There are also useful utilities for debugging and quickchecking.+  .+  This package contains a little example using the Gloss backend.++license:             BSD3+license-file:        LICENSE+author:              Manuel Bärenz+maintainer:          programming@manuelbaerenz.de+homepage:            https://www.manuelbaerenz.de/#computerscience+category:            FRP, Live coding+build-type:          Simple+extra-source-files:  CHANGELOG.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: git@github.com:turion/essence-of-live-coding.git++source-repository this+  type:     git+  location: git@github.com:turion/essence-of-live-coding.git+  tag:      v0.2.1+++executable essence-of-live-coding-gloss-example+  main-is:             Main.hs+  build-depends:+      base >= 4.11 && < 5+    , transformers >= 0.5+    , gloss >= 1.13+    , essence-of-live-coding >= 0.2.1+    , essence-of-live-coding-gloss >= 0.2.1+    , syb >= 0.7+  hs-source-dirs:      app+  default-language:    Haskell2010+  default-extensions: StrictData