blank-canvas 0.6 → 0.7.5
raw patch · 68 files changed
Files
- Changelog.md +35/−1
- Graphics/Blank.hs +15/−10
- Graphics/Blank/Canvas.hs +10/−3
- Graphics/Blank/DeviceContext.hs +3/−1
- Graphics/Blank/Generated.hs +59/−57
- Graphics/Blank/JavaScript.hs +32/−29
- Graphics/Blank/Style.hs +3/−1
- Graphics/Blank/Types/CSS.hs +0/−1
- Graphics/Blank/Types/Cursor.hs +36/−37
- Graphics/Blank/Types/Font.hs +15/−13
- Graphics/Blank/Utils.hs +11/−7
- LICENSE +1/−1
- blank-canvas.cabal +40/−97
- wiki-suite/Arc.hs +0/−29
- wiki-suite/Bezier_Curve.hs +0/−20
- wiki-suite/Bounce.hs +0/−67
- wiki-suite/Circle.hs +0/−24
- wiki-suite/Clipping_Region.hs +0/−55
- wiki-suite/Color_Fill.hs +0/−28
- wiki-suite/Color_Square.hs +0/−22
- wiki-suite/Custom_Shape.hs +0/−26
- wiki-suite/Custom_Transform.hs +0/−28
- wiki-suite/Draw_Canvas.hs +0/−20
- wiki-suite/Draw_Device.hs +0/−19
- wiki-suite/Draw_Image.hs +0/−16
- wiki-suite/Favicon.hs +0/−37
- wiki-suite/Font_Size_and_Style.hs +0/−15
- wiki-suite/Get_Image_Data_URL.hs +0/−31
- wiki-suite/Global_Alpha.hs +0/−25
- wiki-suite/Global_Composite_Operations.hs +0/−70
- wiki-suite/Grayscale.hs +0/−33
- wiki-suite/Image_Crop.hs +0/−16
- wiki-suite/Image_Loader.hs +0/−18
- wiki-suite/Image_Size.hs +0/−16
- wiki-suite/Is_Point_In_Path.hs +0/−29
- wiki-suite/Key_Read.hs +0/−52
- wiki-suite/Line.hs +0/−17
- wiki-suite/Line_Cap.hs +0/−23
- wiki-suite/Line_Color.hs +0/−18
- wiki-suite/Line_Join.hs +0/−39
- wiki-suite/Line_Width.hs +0/−17
- wiki-suite/Linear_Gradient.hs +0/−22
- wiki-suite/Load_Image_Data_URL.hs +0/−17
- wiki-suite/Load_Image_Data_URL_2.hs +0/−15
- wiki-suite/Main.hs +0/−298
- wiki-suite/Miter_Limit.hs +0/−32
- wiki-suite/Path.hs +0/−27
- wiki-suite/Pattern.hs +0/−19
- wiki-suite/Quadratic_Curve.hs +0/−20
- wiki-suite/Radial_Gradient.hs +0/−22
- wiki-suite/Rectangle.hs +0/−20
- wiki-suite/Red_Line.hs +0/−17
- wiki-suite/Rotate_Transform.hs +0/−20
- wiki-suite/Rotating_Square.hs +0/−36
- wiki-suite/Rounded_Corners.hs +0/−29
- wiki-suite/Scale_Transform.hs +0/−20
- wiki-suite/Semicircle.hs +0/−21
- wiki-suite/Shadow.hs +0/−20
- wiki-suite/Square.hs +0/−49
- wiki-suite/Text_Align.hs +0/−19
- wiki-suite/Text_Baseline.hs +0/−20
- wiki-suite/Text_Color.hs +0/−16
- wiki-suite/Text_Metrics.hs +0/−28
- wiki-suite/Text_Stroke.hs +0/−17
- wiki-suite/Text_Wrap.hs +0/−34
- wiki-suite/Tic_Tac_Toe.hs +0/−132
- wiki-suite/Translate_Transform.hs +0/−18
- wiki-suite/Wiki.hs +0/−123
Changelog.md view
@@ -1,3 +1,37 @@+### 0.7.5 [2026.01.10]+* Allow building with GHC 9.14.+* Allow building with `scotty-0.30.*`.+* Remove unused `fail`, `semigroups`, and `transformers` dependencies.+* Fix broken cursor image links in Haddocks.++### 0.7.4 [2023.10.05]+* Support building with `scotty-0.20`.++### 0.7.3+* Allow building with GHC 9.0.++### 0.7.2+* Render Unicode codepoints beyond `0xFFFF` properly.++### 0.7.1+* Remove the `wiki-suite` test suite from `blank-canvas.cabal`, as it was never+ intended to work as a traditional test suite. The functionality of+ `wiki-suite` has moved to a subdirectory of the upstream `blank-canvas`+ repository.++## 0.7+* Strengthen the `Monad` constraint on `readColourName` to `MonadFail`.++#### 0.6.3+* Use `base-compat-batteries`.++### 0.6.2+Additions+ * Add `Semigroup` instance for `Canvas`++### 0.6.1+* Fix building with `aeson-1.2.2.0`.+ ### 0.6 API changes * The `(#)` function had its type generalized from `a -> (a -> Canvas b) -> Canvas b` to `a -> (a -> b) -> b`. This allows it to be used with font length units.@@ -9,7 +43,7 @@ * A generalized `font` function of type `CanvasFont canvasFont => canvasFont -> Canvas ()` was added to `Graphics.Blank.Font` that can accept a `Text` or `Font` argument. The `font` function in `Graphics.Blank` remains of type `Text -> Canvas ()`. * Added a `cursor` function to change the browser cursor. Also added the `Graphics.Blank.Cursor` module containing a generalized `cursor` function that uses a `Cursor` ADT instead of `Text`. * Added `Bounded`, `Enum`, `Eq`, `Ix`, `Ord`, and `Show` instances for more data types- * Added support for more MIME types via the `mime-types` library`+ * Added support for more MIME types via the `mime-types` library Additions * Allowed building with `base-4.8.0.0`
Graphics/Blank.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}@@ -170,11 +171,9 @@ import Control.Monad (forever) import Control.Monad.IO.Class -import Data.Aeson+import Data.Aeson (Result(..), fromJSON) import Data.Aeson.Types (parse)-import Data.List as L import qualified Data.Map as M (lookup)-import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text)@@ -250,7 +249,7 @@ [ "register(" <> showt nm <> ");" | nm <- events opts ]- + queue <- atomically newTChan _ <- forkIO $ forever $ do val <- atomically $ readTChan $ KC.eventQueue $ kc_doc@@ -258,21 +257,21 @@ Success (event :: Event) -> do atomically $ writeTChan queue event _ -> return ()- - ++ let cxt0 = DeviceContext kc_doc queue 300 300 1 locals False- + -- A bit of bootstrapping DeviceAttributes w h dpr <- send cxt0 device -- print (DeviceAttributes w h dpr)- + let cxt1 = cxt0 { ctx_width = w , ctx_height = h , ctx_devicePixelRatio = dpr , weakRemoteMonad = weak opts }- + (actions $ cxt1) `catch` \ (e :: SomeException) -> do print ("Exception in blank-canvas application:" :: String) print e@@ -293,7 +292,7 @@ -- There has to be a better way of doing this, using function, perhaps? get (Scotty.regex "^/(.*)$") $ do- fileName :: Text <- Scotty.param "1"+ fileName :: Text <- captureParam "1" db <- liftIO $ atomically $ readTVar $ locals if fileName `S.member` db then do@@ -309,6 +308,12 @@ $ setTimeout 5 $ defaultSettings ) app+ where+#if MIN_VERSION_scotty(0,20,0)+ captureParam = Scotty.captureParam+#else+ captureParam = Scotty.param+#endif -- | Sends a set of canvas commands to the 'Canvas'. Attempts -- to common up as many commands as possible. Should not crash.
Graphics/Blank/Canvas.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -12,7 +13,6 @@ import Data.Aeson (FromJSON(..),Value(..),encode) import Data.Aeson.Types (Parser, (.:))-import Data.Monoid import Data.Text (Text) import Data.Text.Lazy.Builder import Data.Text.Lazy.Encoding (decodeUtf8)@@ -48,18 +48,25 @@ Return :: a -> Canvas a instance Monad Canvas where+#if !(MIN_VERSION_base(4,11,0)) return = Return+#endif (>>=) = Bind instance Applicative Canvas where- pure = return+ pure = Return (<*>) = ap instance Functor Canvas where fmap f c = c >>= return . f +instance Semigroup a => Semigroup (Canvas a) where+ (<>) = liftM2 (<>)+ instance Monoid a => Monoid (Canvas a) where+#if !(MIN_VERSION_base(4,11,0)) mappend = liftM2 mappend+#endif mempty = return mempty -- HTML5 Canvas assignments: FillStyle, Font, GlobalAlpha, GlobalCompositeOperation, LineCap, LineJoin, LineWidth, MiterLimit, ShadowBlur, ShadowColor, ShadowOffsetX, ShadowOffsetY, StrokeStyle, TextAlign, TextBaseline@@ -351,7 +358,7 @@ getImageData :: (Double, Double, Double, Double) -> Canvas ImageData getImageData = Query . GetImageData --- | Change the canvas cursor to the specified URL or keyword. +-- | Change the canvas cursor to the specified URL or keyword. -- -- ==== __Examples__ --
Graphics/Blank/DeviceContext.hs view
@@ -1,14 +1,16 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.DeviceContext where import Control.Concurrent.STM import Data.Set (Set)-import Data.Monoid ((<>)) import Data.Text (Text) import Graphics.Blank.Events import Graphics.Blank.JavaScript++import Prelude.Compat import TextShow (Builder, toText)
Graphics/Blank/Generated.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Blank.Generated where -import Data.Monoid ((<>)) import Data.Text (Text) import Graphics.Blank.Canvas@@ -10,6 +10,8 @@ import Graphics.Blank.Types import Graphics.Blank.Types.Font +import Prelude.Compat+ import TextShow (TextShow(..), FromTextShow(..), showb, singleton) instance Show Method where@@ -85,17 +87,17 @@ -- DSL -- | @'arc'(x, y, r, sAngle, eAngle, cc)@ creates a circular arc, where--- +-- -- * @x@ is the x-coordinate of the center of the circle--- +-- -- * @y@ is the y-coordinate of the center of the circle--- +-- -- * @r@ is the radius of the circle on which the arc is drawn--- +-- -- * @sAngle@ is the starting angle (where @0@ at the 3 o'clock position of the circle)--- +-- -- * @eAngle@ is the ending angle--- +-- -- * @cc@ is the arc direction, where @True@ indicates counterclockwise and -- @False@ indicates clockwise. arc :: (Double, Double, Double, Radians, Radians, Bool) -> Canvas ()@@ -103,15 +105,15 @@ -- | @'arcTo'(x1, y1, x2, y2, r)@ creates an arc between two tangents, -- specified by two control points and a radius.--- +-- -- * @x1@ is the x-coordinate of the first control point--- +-- -- * @y1@ is the y-coordinate of the first control point--- +-- -- * @x2@ is the x-coordinate of the second control point--- +-- -- * @y2@ is the y-coordinate of the second control point--- +-- -- * @r@ is the arc's radius arcTo :: (Double, Double, Double, Double, Double) -> Canvas () arcTo = Method . ArcTo@@ -119,7 +121,7 @@ -- | Begins drawing a new path. This will empty the current list of subpaths. -- -- ==== __Example__--- +-- -- @ -- 'beginPath'() -- 'moveTo'(20, 20)@@ -131,17 +133,17 @@ -- | @'bezierCurveTo'(cp1x, cp1y, cp2x, cp2y x, y)@ adds a cubic Bézier curve to the path -- (whereas 'quadraticCurveTo' adds a quadratic Bézier curve).--- +-- -- * @cp1x@ is the x-coordinate of the first control point--- +-- -- * @cp1y@ is the y-coordinate of the first control point--- +-- -- * @cp2x@ is the x-coordinate of the second control point--- +-- -- * @cp2y@ is the y-coordinate of the second control point--- +-- -- * @x@ is the x-coordinate of the end point--- +-- -- * @y@ is the y-coordinate of the end point bezierCurveTo :: (Double, Double, Double, Double, Double, Double) -> Canvas () bezierCurveTo = Method . BezierCurveTo@@ -150,7 +152,7 @@ -- corner @(x, y)@, width @w@, and height @h@ (i.e., sets the pixels to transparent black). -- -- ==== __Example__--- +-- -- @ -- 'fillStyle' \"red\" -- 'fillRect'(0, 0, 300, 150)@@ -161,10 +163,10 @@ -- | Turns the path currently being built into the current clipping path. -- Anything drawn after 'clip' is called will only be visible if inside the new--- clipping path. +-- clipping path. -- -- ==== __Example__--- +-- -- @ -- 'rect'(50, 20, 200, 120) -- 'stroke'()@@ -178,7 +180,7 @@ -- | Creates a path from the current point back to the start, to close it. -- -- ==== __Example__--- +-- -- @ -- 'beginPath'() -- 'moveTo'(20, 20)@@ -197,7 +199,7 @@ -- | Fills the current path with the current 'fillStyle'. -- -- ==== __Example__--- +-- -- @ -- 'rect'(10, 10, 100, 100) -- 'fill'()@@ -209,7 +211,7 @@ -- corner @(x, y)@, width @w@, and height @h@ using the current 'fillStyle'. -- -- ==== __Example__--- +-- -- @ -- 'fillStyle' \"red\" -- 'fillRect'(0, 0, 300, 150)@@ -220,13 +222,13 @@ -- | Sets the color, gradient, or pattern used to fill a drawing ('black' by default). -- -- ==== __Examples__--- +-- -- @ -- 'fillStyle' 'red'--- +-- -- grd <- 'createLinearGradient'(0, 0, 10, 10) -- 'fillStyle' grd--- +-- -- img <- 'newImage' \"/myImage.jpg\" -- pat <- 'createPattern'(img, 'Repeat') -- 'fillStyle' pat@@ -238,7 +240,7 @@ -- using the current 'fillStyle'. -- -- ==== __Example__--- +-- -- @ -- 'font' \"48px serif\" -- 'fillText'(\"Hello, World!\", 50, 100)@@ -249,7 +251,7 @@ -- | Sets the text context's font properties. -- -- ==== __Examples__--- +-- -- @ -- 'font' ('defFont' "Gill Sans Extrabold") { 'fontSize' = 40 # 'pt' } -- 'font' ('defFont' 'sansSerif') { 'fontSize' = 80 # 'percent' }@@ -269,7 +271,7 @@ -- | Sets how new shapes should be drawn over existing shapes. -- -- ==== __Examples__--- +-- -- @ -- 'globalCompositeOperation' \"source-over\" -- 'globalCompositeOperation' \"destination-atop\"@@ -289,7 +291,7 @@ -- coordinates (without actually drawing it). -- -- ==== __Example__--- +-- -- @ -- 'beginPath'() -- 'moveTo'(50, 50)@@ -311,7 +313,7 @@ -- | @'moveTo'(x, y)@ moves the starting point of a new subpath to the given @(x, y)@ coordinates. -- -- ==== __Example__--- +-- -- @ -- 'beginPath'() -- 'moveTo'(50, 50)@@ -327,13 +329,13 @@ -- | @'quadraticCurveTo'(cpx, cpy, x, y)@ adds a quadratic Bézier curve to the path -- (whereas 'bezierCurveTo' adds a cubic Bézier curve).--- +-- -- * @cpx@ is the x-coordinate of the control point--- +-- -- * @cpy@ is the y-coordinate of the control point--- +-- -- * @x@ is the x-coordinate of the end point--- +-- -- * @y@ is the y-coordinate of the end point quadraticCurveTo :: (Double, Double, Double, Double) -> Canvas () quadraticCurveTo = Method . QuadraticCurveTo@@ -342,7 +344,7 @@ -- @(x, y)@, width @w@, and height @h@ (where width and height are in pixels). -- -- ==== __Example__--- +-- -- @ -- 'rect'(10, 10, 100, 100) -- 'fill'()@@ -360,7 +362,7 @@ -- the angle given to 'rotate' (in radians). -- -- ==== __Example__--- +-- -- @ -- 'rotate' ('pi'/2) -- Rotate the canvas 90° -- 'fillRect'(0, 0, 20, 10) -- Draw a 10x20 rectangle@@ -377,7 +379,7 @@ -- scale vertically. By default, one canvas unit is one pixel. -- -- ==== __Examples__--- +-- -- @ -- 'scale'(0.5, 0.5) -- Halve the canvas units -- 'fillRect'(0, 0, 20, 20) -- Draw a 10x10 square@@ -398,7 +400,7 @@ -- | Sets the color used for shadows. -- -- ==== __Examples__--- +-- -- @ -- 'shadowColor' 'red' -- 'shadowColor' $ 'rgb' 0 255 0@@ -417,7 +419,7 @@ -- | Draws the current path's strokes with the current 'strokeStyle' ('black' by default). -- -- ==== __Example__--- +-- -- @ -- 'rect'(10, 10, 100, 100) -- 'stroke'()@@ -429,7 +431,7 @@ -- corner @(x, y)@, width @w@, and height @h@ using the current 'strokeStyle'. -- -- ==== __Example__--- +-- -- @ -- 'strokeStyle' \"red\" -- 'strokeRect'(0, 0, 300, 150)@@ -440,13 +442,13 @@ -- | Sets the color, gradient, or pattern used for strokes. -- -- ==== __Examples__--- +-- -- @ -- 'strokeStyle' 'red'--- +-- -- grd <- 'createLinearGradient'(0, 0, 10, 10) -- 'strokeStyle' grd--- +-- -- img <- 'newImage' \"/myImage.jpg\" -- pat <- 'createPattern'(img, 'Repeat') -- 'strokeStyle' pat@@ -458,7 +460,7 @@ -- using the current 'strokeStyle'. -- -- ==== __Example__--- +-- -- @ -- 'font' \"48px serif\" -- 'strokeText'(\"Hello, World!\", 50, 100)@@ -476,25 +478,25 @@ -- | Applies a transformation by multiplying a matrix to the canvas's -- current transformation. If @'transform'(a, b, c, d, e, f)@ is called, the matrix--- +-- -- @ -- ( a c e ) -- ( b d f ) -- ( 0 0 1 ) -- @--- +-- -- is multiplied by the current transformation. The parameters are:--- +-- -- * @a@ is the horizontal scaling--- +-- -- * @b@ is the horizontal skewing--- +-- -- * @c@ is the vertical skewing--- +-- -- * @d@ is the vertical scaling--- +-- -- * @e@ is the horizontal movement--- +-- -- * @f@ is the vertical movement transform :: (Double, Double, Double, Double, Double, Double) -> Canvas () transform = Method . Transform@@ -502,10 +504,10 @@ -- | Applies a translation transformation by remapping the origin (i.e., the (0,0) -- position) on the canvas. When you call functions such as 'fillRect' after -- 'translate', the values passed to 'translate' are added to the x- and--- y-coordinate values. +-- y-coordinate values. -- -- ==== __Example__--- +-- -- @ -- 'translate'(20, 20) -- 'fillRect'(0, 0, 40, 40) -- Draw a 40x40 square, starting in position (20, 20)
Graphics/Blank/JavaScript.hs view
@@ -1,36 +1,38 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} module Graphics.Blank.JavaScript where -import Data.Char (isControl, isAscii, ord)+import Data.Bits (shiftR, (.&.))+import Data.Char (isAscii, isControl, ord) import Data.Colour import Data.Colour.SRGB import Data.Default.Class import Data.Ix-import Data.Monoid ((<>))-import Data.List+import qualified Data.List as L import Data.String-import Data.Text (Text)-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as B (singleton)-import qualified Data.Vector.Unboxed as V-import Data.Vector.Unboxed (Vector, toList)-import Data.Word (Word8)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as B (singleton)+import Data.Vector.Unboxed (Vector, toList)+import qualified Data.Vector.Unboxed as V+import Data.Word (Word8) import Graphics.Blank.Parser import Prelude.Compat -import Text.ParserCombinators.ReadP (choice, skipSpaces)+import Text.ParserCombinators.ReadP (choice, skipSpaces) import Text.ParserCombinators.ReadPrec (lift)-import Text.Read (Read(..), parens, readListPrecDefault)+import Text.Read (Read (..), parens,+ readListPrecDefault) +import Numeric (showHex) import TextShow-import TextShow.Data.Floating (showbFFloat)-import TextShow.Data.Integral (showbHex)-import TextShow.TH (deriveTextShow)+import TextShow.Data.Floating (showbFFloat)+import TextShow.Data.Integral (showbHex)+import TextShow.TH (deriveTextShow) ------------------------------------------------------------- @@ -505,7 +507,7 @@ jsLineJoinCorner = jsLiteralBuilder . showb jsList :: (a -> Builder) -> [a] -> Builder-jsList js = mconcat . intersperse "," . map js+jsList js = mconcat . L.intersperse "," . map js instance JSArg RepeatDirection where showbJS = jsRepeatDirection@@ -544,13 +546,6 @@ jsQuoteBuilder :: Builder -> Builder jsQuoteBuilder b = B.singleton '"' <> b <> B.singleton '"' --- | Transform a character to a lazy 'TL.Text' that represents its JS--- unicode escape sequence.-jsUnicodeChar :: Char -> TL.Text-jsUnicodeChar c =- let hex = toLazyText . showbHex $ ord c- in "\\u" <> TL.replicate (4 - TL.length hex) (TL.singleton '0') <> hex- -- | Correctly replace a `Builder'`s characters by the JS escape sequences. jsEscapeBuilder :: Builder -> Builder jsEscapeBuilder = fromLazyText . TL.concatMap jsEscapeChar . toLazyText@@ -559,8 +554,6 @@ jsEscapeChar :: Char -> TL.Text jsEscapeChar '\\' = "\\\\" -- Special control sequences.-jsEscapeChar '\0' = jsUnicodeChar '\0' -- Ambigous with numbers-jsEscapeChar '\a' = jsUnicodeChar '\a' -- Non JS jsEscapeChar '\b' = "\\b" jsEscapeChar '\f' = "\\f" jsEscapeChar '\n' = "\\n"@@ -569,7 +562,17 @@ jsEscapeChar '\v' = "\\v" jsEscapeChar '\"' = "\\\"" jsEscapeChar '\'' = "\\'"--- Non-control ASCII characters can remain as they are.-jsEscapeChar c' | not (isControl c') && isAscii c' = TL.singleton c'--- All other non ASCII signs are escaped to unicode.-jsEscapeChar c' = jsUnicodeChar c'+-- Code borrowed from GHCJS implementation: https://github.com/ghcjs/ghcjs/blob/718b37fc7167269ebca633914c716c3dbe6d0faf/src/Compiler/JMacro/Base.hs#L887-L905+jsEscapeChar '/' = "\\/"+jsEscapeChar c+ -- Non-control ASCII characters can remain as they are.+ | not (isControl c) && isAscii c = TL.singleton c+ | ord c <= 0xff = hexxs "\\x" 2 (ord c)+ -- All other non ASCII signs are escaped to unicode.+ | ord c <= 0xffff = hexxs "\\u" 4 (ord c)+ | otherwise = let cp0 = ord c - 0x10000 -- output surrogate pair+ in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) `mappend`+ hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00)+ where hexxs prefix pad cp =+ let h = showHex cp ""+ in TL.pack (prefix ++ replicate (pad - length h) '0' ++ h)
Graphics/Blank/Style.hs view
@@ -189,6 +189,8 @@ , rebeccapurple ) where +import qualified Control.Monad.Fail as Fail+ import qualified Data.Colour as Colour import Data.Colour hiding (black, transparent) import qualified Data.Colour.Names as Names@@ -248,7 +250,7 @@ -- | -- Takes a string naming a 'Colour' (must be all lowercase) and returns it. Fails if -- the name is not recognized.-readColourName :: Monad m => String -> m (Colour Double)+readColourName :: Fail.MonadFail m => String -> m (Colour Double) readColourName "rebeccapurple" = return rebeccapurple readColourName name = Names.readColourName name
Graphics/Blank/Types/CSS.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Blank.Types.CSS where -import Data.Monoid ((<>)) import Data.String import Graphics.Blank.JavaScript
Graphics/Blank/Types/Cursor.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.Types.Cursor where -import Data.Monoid import Data.String (IsString(..)) import qualified Data.Text as TS (Text) import Data.Text (pack)@@ -31,46 +30,46 @@ jsCanvasCursor = jsCursor -- | Specified the mouse cursor's appearance in a web browser.--- +-- -- Images by the Mozilla Developer Network are licensed under -- <http://creativecommons.org/licenses/by-sa/2.5/ CC-BY-SA 2.5>. data Cursor = Auto -- ^ The browser determines the cursor to display based on the -- current context.- | Default -- ^ <<https://developer.mozilla.org/@api/deki/files/3438/=default.gif>>+ | Default -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/default.gif>> | None -- ^ No cursor is rendered.- | ContextMenu -- ^ <<https://developer.mozilla.org/@api/deki/files/3461/=context-menu.png>>- | Help -- ^ <<https://developer.mozilla.org/@api/deki/files/3442/=help.gif>>- | Pointer -- ^ <<https://developer.mozilla.org/@api/deki/files/3449/=pointer.gif>>- | Progress -- ^ <<https://developer.mozilla.org/@api/deki/files/3450/=progress.gif>>- | Wait -- ^ <<https://developer.mozilla.org/@api/deki/files/3457/=wait.gif>>- | Cell -- ^ <<https://developer.mozilla.org/@api/deki/files/3434/=cell.gif>>- | Crosshair -- ^ <<https://developer.mozilla.org/@api/deki/files/3437/=crosshair.gif>>- | Text -- ^ <<https://developer.mozilla.org/files/3809/text.gif>>- | VerticalText -- ^ <<https://developer.mozilla.org/@api/deki/files/3456/=vertical-text.gif>>- | Alias -- ^ <<https://developer.mozilla.org/@api/deki/files/3432/=alias.gif>>- | Copy -- ^ <<https://developer.mozilla.org/@api/deki/files/3436/=copy.gif>>- | Move -- ^ <<https://developer.mozilla.org/@api/deki/files/3443/=move.gif>>- | NoDrop -- ^ <<https://developer.mozilla.org/@api/deki/files/3445/=no-drop.gif>>- | NotAllowed -- ^ <<https://developer.mozilla.org/@api/deki/files/3446/=not-allowed.gif>>- | AllScroll -- ^ <<https://developer.mozilla.org/@api/deki/files/3433/=all-scroll.gif>>- | ColResize -- ^ <<https://developer.mozilla.org/@api/deki/files/3435/=col-resize.gif>>- | RowResize -- ^ <<https://developer.mozilla.org/@api/deki/files/3451/=row-resize.gif>>- | NResize -- ^ <<https://developer.mozilla.org/files/4083/n-resize.gif>>- | EResize -- ^ <<https://developer.mozilla.org/files/4085/e-resize.gif>>- | SResize -- ^ <<https://developer.mozilla.org/files/4087/s-resize.gif>>- | WResize -- ^ <<https://developer.mozilla.org/files/4089/w-resize.gif>>- | NEResize -- ^ <<https://developer.mozilla.org/files/4091/ne-resize.gif>>- | NWResize -- ^ <<https://developer.mozilla.org/files/4093/nw-resize.gif>>- | SEResize -- ^ <<https://developer.mozilla.org/files/4097/se-resize.gif>>- | SWResize -- ^ <<https://developer.mozilla.org/files/4095/sw-resize.gif>>- | EWResize -- ^ <<https://developer.mozilla.org/files/3806/3-resize.gif>>- | NSResize -- ^ <<https://developer.mozilla.org/files/3808/6-resize.gif>>- | NESWResize -- ^ <<https://developer.mozilla.org/files/3805/1-resize.gif>>- | NWSEResize -- ^ <<https://developer.mozilla.org/files/3807/4-resize.gif>>- | ZoomIn -- ^ <<https://developer.mozilla.org/@api/deki/files/3459/=zoom-in.gif>>- | ZoomOut -- ^ <<https://developer.mozilla.org/@api/deki/files/3460/=zoom-out.gif>>- | Grab -- ^ <<https://developer.mozilla.org/@api/deki/files/3440/=grab.gif>>- | Grabbing -- ^ <<https://developer.mozilla.org/@api/deki/files/3441/=grabbing.gif>>+ | ContextMenu -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/context-menu.png>>+ | Help -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/help.gif>>+ | Pointer -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/pointer.gif>>+ | Progress -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/progress.gif>>+ | Wait -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/wait.gif>>+ | Cell -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/cell.gif>>+ | Crosshair -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/crosshair.gif>>+ | Text -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/text.gif>>+ | VerticalText -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/vertical-text.gif>>+ | Alias -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/alias.gif>>+ | Copy -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/copy.gif>>+ | Move -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/move.gif>>+ | NoDrop -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/no-drop.gif>>+ | NotAllowed -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/not-allowed.gif>>+ | AllScroll -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/all-scroll.gif>>+ | ColResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/col-resize.gif>>+ | RowResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/row-resize.gif>>+ | NResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/n-resize.gif>>+ | EResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/e-resize.gif>>+ | SResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/s-resize.gif>>+ | WResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/w-resize.gif>>+ | NEResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/ne-resize.gif>>+ | NWResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/nw-resize.gif>>+ | SEResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/se-resize.gif>>+ | SWResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/sw-resize.gif>>+ | EWResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/3-resize.gif>>+ | NSResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/6-resize.gif>>+ | NESWResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/1-resize.gif>>+ | NWSEResize -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/4-resize.gif>>+ | ZoomIn -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/zoom-in.gif>>+ | ZoomOut -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/zoom-out.gif>>+ | Grab -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/grab.gif>>+ | Grabbing -- ^ <<https://developer.mozilla.org/en-US/docs/Web/CSS/cursor/grabbing.gif>> | URL TS.Text Cursor -- ^ An image from a URL. Must be followed by another 'Cursor'. deriving (Eq, Ord)@@ -134,7 +133,7 @@ _ <- char ',' URL url' <$> unlift readPrec ]- + readListPrec = readListPrecDefault readURL :: Maybe Char -> ReadP TS.Text
Graphics/Blank/Types/Font.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.Types.Font where @@ -9,7 +10,6 @@ import Data.Default.Class import Data.Ix (Ix) import Data.Maybe-import Data.Monoid import Data.String import qualified Data.Text as TS import Data.Text (Text)@@ -20,6 +20,8 @@ import Graphics.Blank.Types import Graphics.Blank.Types.CSS +import Prelude.Compat+ import qualified Text.ParserCombinators.ReadP as ReadP import Text.ParserCombinators.ReadP hiding ((<++), choice, pfail) import qualified Text.ParserCombinators.ReadPrec as ReadPrec@@ -65,7 +67,7 @@ -- for the other five longhand properties. If you only wish to change certain -- properties and leave the others alone, this provides a convenient mechanism -- for doing so:--- +-- -- @ -- ('defFont' ["Gill Sans Extrabold", 'sansSerif']) { -- 'fontStyle' = 'italic'@@ -136,7 +138,7 @@ -- make it easier to catch bad input. The three Maybe arguments each represent whether its -- respective property has not (Nothing) or has (Just) been read. If it has been read, then -- readFontProperties will not attempt to parse it again.--- +-- -- readFontProperties will proceed to parse the remaining Font longhand properties once -- either all three of the first properties have been parsed, or when it is unsuccessful at -- parsing any of the first three properties.@@ -149,12 +151,12 @@ -- If the property has already been parsed, do not parse it again. let parseCheck :: Maybe a -> ReadPrec a -> ReadPrec a parseCheck mb parser = if isJust mb then pfail else parser- + readStyle, readVariant, readWeight :: ReadPrec (OneOfThree FontStyle FontVariant FontWeight) readStyle = One <$> parseCheck style readPrec readVariant = Two <$> parseCheck variant readPrec readWeight = Three <$> parseCheck weight readPrec- + -- First attempt to parse font-style, then font-variant, then font-weight (unless one -- of them has already been parsed, in which case skip to the next property parser. prop <- maybeReadPrec $ readStyle <++ readVariant <++ readWeight@@ -286,11 +288,11 @@ -- | -- Specifies the boldness of a 'Font'. Note that 'FontWeight' is an instance of -- 'Num' so that the nine numeric weights can be used directly. For example:--- +-- -- @ -- ('defFont' ['sansSerif']) { 'fontWeight' = 900 } -- @--- +-- -- Attempting to use a numeric weight other than the nine given will result in -- a runtime error. data FontWeight = NormalWeight -- ^ Default.@@ -566,16 +568,16 @@ -- The name of a 'Font' family. Note that both 'FontFamily' and @['FontFamily']@ -- are instances of 'IsString', so it is possible to produce 'FontFamily' values -- in several different ways. For example, these are all of type 'FontFamily':--- +-- -- @ -- 'FontFamilyName' "Gill Sans Extrabold" -- "Gill Sans Extrabold" :: 'FontFamily' -- 'serif' -- "serif" :: 'FontFamily' -- @--- +-- -- These are all of type @['FontFamily']@:--- +-- -- @ -- ['FontFamilyName' \"Helvetica\", 'serif'] -- [\"Helvetica\", "serif"] :: ['FontFamily']@@ -636,7 +638,7 @@ <|> quoted '\'' (readFontFamily $ Just '\'') <|> readFontFamily Nothing ]- + -- readListPrec is overloaded so that it will read in a comma-separated list of -- family names not delimited by square brackets, as per the CSS syntax. readListPrec = lift . sepBy1 (unlift readPrec) $ skipSpaces *> char ','@@ -659,7 +661,7 @@ showb MonospaceFamily = "monospace" showb CursiveFamily = "cursive" showb FantasyFamily = "fantasy"- + -- Omit the square brackets when showing a list of font families so that -- it matches the CSS syntax. showbList = jsList showb@@ -671,7 +673,7 @@ class Default a => NormalProperty a where -- | The default value for a CSS property. For example, it can be used -- like this:- -- + -- -- @ -- ('defFont' ['sansSerif']) { 'lineHeight' = 'normal' } -- @
Graphics/Blank/Utils.hs view
@@ -1,9 +1,9 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.Utils where import Data.ByteString.Base64 -- Not sure why to use this, vs this *.URL version. This one works, though. import qualified Data.ByteString as B-import Data.Monoid import Data.Text(Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)@@ -12,6 +12,8 @@ import Graphics.Blank.Generated import Graphics.Blank.JavaScript +import Prelude.Compat+ -- | Clear the screen. Restores the default transformation matrix. clearCanvas :: Canvas () clearCanvas = do@@ -31,9 +33,9 @@ -- | The @#@-operator is the Haskell analog to the @.@-operator -- in JavaScript. Example:--- +-- -- > grd # addColorStop(0, "#8ED6FF");--- +-- -- This can be seen as equivalent of @grd.addColorStop(0, "#8ED6FF")@. (#) :: a -> (a -> b) -> b (#) obj act = act obj@@ -48,7 +50,7 @@ return $ "data:" <> mime_type <> ";base64," <> decodeUtf8 (encode dat) -- | Find the MIME type for a data URL.--- +-- -- > > dataURLMimeType "data:image/png;base64,iVBORw..." -- > "image/png" dataURLMimeType :: Text -> Text@@ -58,7 +60,9 @@ | otherwise = error "dataURLMimeType: bad parse" where (dat,rest0) = Text.span (/= ':') txt- Just (_,rest1) = Text.uncons rest0+ rest1 = case Text.uncons rest0 of+ Just (_,rest1') -> rest1'+ Nothing -> "dataURLMimeType: Unexpected empty Text" (mime_type,rest2) = Text.span (/= ';') rest1 -- | Write a data URL to a given file.@@ -83,7 +87,7 @@ -- of 'drawImageSize'. The first and second 'Double's specify the x- and y-coordinates at -- which the image begins to crop. The third and fourth 'Double's specify the width and -- height of the cropped image.--- +-- -- @ -- 'drawImageCrop' img 0 0 dw dh dx dy dw dh = 'drawImageSize' = dx dy dw dh -- @@@ -99,7 +103,7 @@ -- which region of the 'ImageData' (the dirty rectangle) should be drawn. The third -- and fourth 'Double's specify the dirty rectangle's x- and y- coordinates, and the -- fifth and sixth 'Double's specify the dirty rectangle's width and height.--- +-- -- @ -- 'putImageDataDirty' imgData dx dy 0 0 w h = 'putImageDataAt' imgData dx dy -- where (w, h) = case imgData of ImageData w' h' _ -> (w', h')
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2015, The University of Kansas+Copyright (c) 2012-2020, The University of Kansas All rights reserved.
blank-canvas.cabal view
@@ -1,5 +1,5 @@ Name: blank-canvas-Version: 0.6+Version: 0.7.5 Synopsis: HTML5 Canvas Graphics Library Description: @blank-canvas@ is a Haskell binding to the complete@@ -41,6 +41,20 @@ Extra-source-files: README.md Changelog.md Cabal-version: >= 1.10+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 data-files: static/index.html static/jquery.js@@ -67,105 +81,34 @@ Paths_blank_canvas default-language: Haskell2010- build-depends: aeson >= 0.7 && < 0.11,- base64-bytestring == 1.0.*,- base >= 4.6 && < 4.9,- base-compat >= 0.8.1 && < 1,- bytestring == 0.10.*,- colour >= 2.2 && < 3.0,- containers == 0.5.*,- data-default-class == 0.0.*,- http-types >= 0.8 && < 0.10,- mime-types >= 0.1.0.3 && < 0.2,- kansas-comet >= 0.4 && < 0.5,- scotty >= 0.10 && < 0.11,- stm >= 2.2 && < 2.5,- text >= 1.1 && < 1.3,- text-show >= 2 && < 2.2,- transformers >= 0.3 && < 0.5,- wai == 3.*,- wai-extra >= 3.0.1 && < 3.1,- warp == 3.*,- vector >= 0.10 && < 0.12+ build-depends: aeson >= 1.4.4 && < 2.3,+ base64-bytestring >= 1.0 && < 1.3,+ base >= 4.9 && < 4.23,+ base-compat-batteries >= 0.10 && < 0.15,+ bytestring >= 0.10 && < 0.13,+ colour >= 2.2 && < 2.4,+ containers >= 0.5 && < 0.9,+ data-default-class >= 0.0.1 && < 0.3,+ http-types >= 0.8 && < 0.13,+ mime-types >= 0.1.0.3 && < 0.2,+ kansas-comet >= 0.4 && < 0.5,+ -- TODO: Eventually, we should bump the lower version+ -- bounds to >=0.20 so that we can remove some CPP in+ -- Graphics.Blank.+ scotty >= 0.10 && < 0.31,+ stm >= 2.2 && < 2.6,+ text >= 1.1 && < 2.2,+ text-show >= 2 && < 4,+ wai == 3.*,+ wai-extra >= 3.0.1 && < 3.2,+ warp == 3.*,+ vector >= 0.10 && < 0.14 GHC-options: -Wall+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type GHC-prof-options: -Wall -fsimpl-tick-factor=100000 --test-suite wiki-suite- build-depends: base >= 4.6 && < 4.9,- blank-canvas == 0.6.*,- containers == 0.5.*,- process == 1.2.*,- directory >= 1.2,- shake >= 0.13,- stm >= 2.2 && < 2.5,- text >= 1.1 && < 1.3,- time >= 1.4 && < 1.6,- unix == 2.7.*,- vector >= 0.10 && < 0.12-- default-language: Haskell2010- GHC-options: -threaded -Wall- main-is: Main.hs- hs-source-dirs: wiki-suite- type: exitcode-stdio-1.0- other-modules: Arc- Bezier_Curve- Bounce- Circle- Clipping_Region- Color_Fill- Color_Square- Custom_Shape- Custom_Transform- Draw_Canvas- Draw_Device- Draw_Image- Favicon- Font_Size_and_Style- Get_Image_Data_URL- Global_Alpha- Global_Composite_Operations- Grayscale- Image_Crop- Image_Loader- Image_Size- Is_Point_In_Path- Key_Read- Line- Line_Cap- Line_Color- Line_Join- Line_Width- Linear_Gradient- Load_Image_Data_URL- Load_Image_Data_URL_2- Miter_Limit- Path- Pattern- Quadratic_Curve- Radial_Gradient- Rectangle- Red_Line- Rotate_Transform- Rotating_Square- Rounded_Corners- Scale_Transform- Semicircle- Shadow- Square- Text_Align- Text_Baseline- Text_Color- Text_Metrics- Text_Stroke- Text_Wrap- Tic_Tac_Toe- Translate_Transform- Wiki-- source-repository head type: git- location: git://github.com/ku-fpg/blank-canvas.git+ location: https://github.com/ku-fpg/blank-canvas.git
− wiki-suite/Arc.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Arc where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let centerX = width context / 2;- let centerY = height context / 2;- let radius = 75;- let startingAngle = 1.1 * pi- let endingAngle = 1.9 * pi- lineWidth 15- strokeStyle "black"-- beginPath()- arc(centerX - 50, centerY, radius, startingAngle, endingAngle, False)- stroke()-- beginPath()- strokeStyle "blue"- arc(centerX + 50, centerY, radius, startingAngle, endingAngle, True)- stroke()--- wiki $ snapShot context "images/Arc.png"- wiki $ close context
− wiki-suite/Bezier_Curve.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Bezier_Curve where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath()- moveTo(188, 150)- bezierCurveTo(140, 10, 388, 10, 388, 170)- lineWidth 10- -- line color- strokeStyle "black"- stroke()--- wiki $ snapShot context "images/Bezier_Curve.png"- wiki $ close context
− wiki-suite/Bounce.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Bounce where--import Control.Concurrent-import Control.Monad -- wiki $-import Data.Text (Text)-import Graphics.Blank-import Wiki -- (512,384)--main :: IO ()-main = blankCanvas 3000 { events = ["mousedown"] } $ go--type Ball a = ((Double, Double), Double, a)--type Color = String--epoch :: [Ball ()]-epoch = []--type State = ([Ball Color])--showBall :: (Double, Double) -> Text -> Canvas ()-showBall (x,y) col = do- beginPath()- globalAlpha 0.5- fillStyle col- arc(x, y, 50, 0, pi*2, False)- closePath()- fill()--moveBall :: Ball a -> Ball a-moveBall ((x,y),d,a) = ((x,y+d),d+0.5,a)--go :: DeviceContext -> IO ()-go context = do- let bounce :: Ball a -> Ball a- bounce ((x,y),d,a)- | y + 25 >= height context && d > 0 = ((x,y),-(d-0.5)*0.97,a)- | otherwise = ((x,y),d,a)-- let loop (balls,cols) = do-- send context $ do- clearCanvas- sequence_- [ showBall xy col- | (xy,_,col) <- balls- ]- threadDelay (20 * 1000) -- wiki $ counter (\ _ -> True) $ \ n -> do- file <- wiki $ anim_png "Bounce"- wiki $ when (n `mod` 43 == 0) $ send context $ trigger $ Event { eMetaKey = False, ePageXY = return(fromIntegral (100 + length balls * 45),20), eType = "mousedown", eWhich = Nothing}- wiki $ when (n `mod` 3 == 0) $ snapShot context $ file- wiki $ when (n >= 400) $ do { build_anim "Bounce" 7; close context }-- es <- flush context- if (null es) then return () else print es-- let newBalls = [ ((x,y),0,head cols) - | Just (x,y) <- map ePageXY es- ]-- loop (map bounce $ map moveBall $ balls ++ newBalls, tail cols)--- loop ([((100,100),0,"blue")],cycle ["red","blue","green","orange","cyan"])
− wiki-suite/Circle.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Circle where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let centerX = width context / 2- let centerY = height context / 2- let radius = 70-- beginPath()- arc(centerX, centerY, radius, 0, 2 * pi, False)- fillStyle "#8ED6FF"- fill()- lineWidth 5- strokeStyle "black"- stroke()--- wiki $ snapShot context "images/Circle.png"- wiki $ close context
− wiki-suite/Clipping_Region.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Clipping_Region where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let x = width context / 2;- let y = height context / 2;- let radius = 75;- let offset = 50;-- {-- * save() allows us to save the canvas context before- * defining the clipping region so that we can return- * to the default state later on- -}- save();- beginPath();- arc(x, y, radius, 0, 2 * pi, False);- clip();-- -- draw blue circle inside clipping region- beginPath();- arc(x - offset, y - offset, radius, 0, 2 * pi, False);- fillStyle "blue";- fill();-- -- draw yellow circle inside clipping region- beginPath();- arc(x + offset, y, radius, 0, 2 * pi, False);- fillStyle "yellow";- fill();-- -- draw red circle inside clipping region- beginPath();- arc(x, y + offset, radius, 0, 2 * pi, False);- fillStyle "red";- fill();-- {-- * restore() restores the canvas context to its original state- * before we defined the clipping region- -}- restore();- beginPath();- arc(x, y, radius, 0, 2 * pi, False);- lineWidth 10;- strokeStyle "blue";- stroke();-- wiki $ snapShot context "images/Clipping_Region.png"- wiki $ close context
− wiki-suite/Color_Fill.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Color_Fill where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath();- moveTo(170, 80);- bezierCurveTo(130, 100, 130, 150, 230, 150);- bezierCurveTo(250, 180, 320, 180, 340, 150);- bezierCurveTo(420, 150, 420, 120, 390, 100);- bezierCurveTo(430, 40, 370, 30, 340, 50);- bezierCurveTo(320, 5, 250, 20, 250, 50);- bezierCurveTo(200, 5, 150, 20, 170, 80);-- -- complete custom shape- closePath();- lineWidth 5;- fillStyle "#8ED6FF";- fill();- strokeStyle "blue";- stroke();-- wiki $ snapShot context "images/Color_Fill.png"- wiki $ close context
− wiki-suite/Color_Square.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Color_Square where--import qualified Data.Vector.Unboxed as V-import Graphics.Blank-import Wiki -- (300,300)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- let v = V.fromList- $ concat- $ [ [r,g,0,255]- | r <- [0..255]- , g <- [0..255]- ]-- send context $ do- putImageData (ImageData 256 256 v, [22,22])-- wiki $ snapShot context "images/Color_Square.png"- wiki $ close context-
− wiki-suite/Custom_Shape.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Custom_Shape where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath();- moveTo(170, 80);- bezierCurveTo(130, 100, 130, 150, 230, 150);- bezierCurveTo(250, 180, 320, 180, 340, 150);- bezierCurveTo(420, 150, 420, 120, 390, 100);- bezierCurveTo(430, 40, 370, 30, 340, 50);- bezierCurveTo(320, 5, 250, 20, 250, 50);- bezierCurveTo(200, 5, 150, 20, 170, 80);- -- complete custom shape- closePath();- lineWidth 5;- strokeStyle "blue";- stroke();--- wiki $ snapShot context "images/Custom_Shape.png"- wiki $ close context
− wiki-suite/Custom_Transform.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Custom_Transform where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let rectWidth = 150;- let rectHeight = 75;-- -- translation matrix:- -- 1 0 tx- -- 0 1 ty- -- 0 0 1- let tx = width context / 2;- let ty = height context / 2;-- -- apply custom transform- transform(1, 0, 0, 1, tx, ty);-- fillStyle "blue";- fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);--- wiki $ snapShot context "images/Custom_Transform.png"- wiki $ close context
− wiki-suite/Draw_Canvas.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Draw_Canvas where--import Graphics.Blank -- import the blank canvas-import Wiki -- (600,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000- send context $ do -- send commands to this specific context- moveTo(50,50)- lineTo(200,100)- lineWidth 10- strokeStyle "red"- stroke() -- this draws the ink into the canvas-- me <- myCanvasContext- drawImage(me,[50,50])-- wiki $ snapShot context "images/Draw_Canvas.png"- wiki $ close context
− wiki-suite/Draw_Device.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Draw_Device where--import Graphics.Blank -- import the blank canvas-import Wiki -- (600,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000- send context $ do -- send commands to this specific context- moveTo(50,50)- lineTo(200,100)- lineWidth 10- strokeStyle "red"- stroke() -- this draws the ink into the canvas-- drawImage(context,[50,50])-- wiki $ snapShot context "images/Draw_Device.png"- wiki $ close context
− wiki-suite/Draw_Image.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Draw_Image where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = do- blankCanvas 3000 $ \ context -> do- send context $ do- img <- newImage "images/Haskell.jpg"- drawImage(img,[69,50])--- wiki $ snapShot context "images/Draw_Image.png"- wiki $ close context
− wiki-suite/Favicon.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Favicon where--import Graphics.Blank -- import the blank canvas-import Wiki -- (32,32)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000- send context $ do -- send commands to this specific context-- beginPath()- let relPath x xs = do- beginPath()- moveTo x- sequence_ [ lineTo p | ss <- drop 2 $ scanl (flip (:)) [] (x:xs)- , let p = (sum (map fst ss), sum (map snd ss))- ]- closePath()- - translate(height context * 0.07,height context * 0.8)- scale (height context / 20,-height context / 20)-- let shape x xs col = do- relPath x xs- lineWidth 0.5- fillStyle col- lineCap "round"- fill() -- shape (0,0) [(4,6),(-4,6),(3,0),(4,-6),(-4,-6)] "#E8000D" - shape (8,6) [(-4,6),(3,0),(8,-12),(-3,0),(-2.5,3.75),(-2.5,-3.75),(-3,0)] "#0022B4"- shape (17,3.5) [(-3.5,0),(-8/6,12/6),(3.5+8/6,0)] "#FFC82D" - shape (17,6.5) [(-5.5,0),(-8/6,12/6),(5.5+8/6,0)] "#FFC82D" -- -- wiki $ txt <- send context $ toDataURL() ; print txt- wiki $ snapShot context "images/Favicon.png"- wiki $ close context
− wiki-suite/Font_Size_and_Style.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Font_Size_and_Style where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- font "40pt Calibri"- fillText("Hello World!", 150, 100)--- wiki $ snapShot context "images/Font_Size_and_Style.png"- wiki $ close context
− wiki-suite/Get_Image_Data_URL.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Get_Image_Data_URL where--import qualified Data.Text as Text-import Graphics.Blank-import Wiki -- (578,350)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- url <- send context $ do- beginPath();- moveTo(170, 80);- bezierCurveTo(130, 100, 130, 150, 230, 150);- bezierCurveTo(250, 180, 320, 180, 340, 150);- bezierCurveTo(420, 150, 420, 120, 390, 100);- bezierCurveTo(430, 40, 370, 30, 340, 50);- bezierCurveTo(320, 5, 250, 20, 250, 50);- bezierCurveTo(200, 5, 150, 20, 170, 80);- -- complete custom shape- closePath();- lineWidth 5;- strokeStyle "blue";- stroke();- toDataURL();-- send context $ do- font "18pt Calibri"- fillText(Text.pack $ show $ Text.take 50 $ url, 10, 300)-- wiki $ snapShot context "images/Get_Image_Data_URL.png"- wiki $ close context
− wiki-suite/Global_Alpha.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Global_Alpha where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- -- draw blue rectangle- beginPath();- rect(200, 20, 100, 100);- fillStyle "blue";- fill();-- -- draw transparent red circle- globalAlpha 0.5;- beginPath();- arc(320, 120, 60, 0, 2 * pi, False);- fillStyle "red";- fill();--- wiki $ snapShot context "images/Global_Alpha.png"- wiki $ close context
− wiki-suite/Global_Composite_Operations.hs
@@ -1,70 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Global_Composite_Operations where--import qualified Data.Text as Text-import Graphics.Blank-import Wiki -- (578,430)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do-- tempCanvas <- newCanvas (round (width context :: Double),- round (height context :: Double))- console_log tempCanvas- (w,h) <- return (round (width context :: Double) :: Int,- round (height context :: Double) :: Int)- console_log $ Text.pack $ show $ (w,h)- - let squareWidth = 55;- let circleRadius = 35;- let shapeOffset = 50;-- let compss = - [["source-atop", "source-in", "source-out", "source-over"]- ,["destination-atop","destination-in","destination-out","destination-over"]- ,["lighter","darker","xor","copy"]- ]-- -- translate context to add 10px padding- translate(10, 10);--- sequence_ [- do-- -- clear temp context- with tempCanvas $ do- save();-- clearRect(0, 0, width context, height context);- -- draw rectangle (destination)- beginPath();- rect(0, 0, squareWidth, squareWidth);- fillStyle "blue";- fill();-- -- set global composite- globalCompositeOperation thisOperation;-- -- draw circle (source)- beginPath();- arc(shapeOffset, shapeOffset, circleRadius, 0, 2 * pi, False);- fillStyle "red";- fill();-- restore();-- font "10pt Verdana";- fillStyle "black";- fillText(thisOperation, 0, squareWidth + 45);-- drawImage(tempCanvas, [x * 125, y * 125]);--- | (comps,y) <- compss `zip` [0..]- , (thisOperation,x) <- comps `zip` [0..]- ]-- wiki $ snapShot context "images/Global_Composite_Operations.png"- wiki $ close context
− wiki-suite/Grayscale.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Grayscale where--import qualified Data.Vector.Unboxed as V-import Graphics.Blank-import Wiki -- (578,400)--main :: IO ()-main = do- blankCanvas 3000 $ \ context -> do- ImageData w h v <- send context $ do- img <- newImage "images/House.jpg"- drawImage(img,[50,50])- getImageData(50,50, width img, height img)- - let group4 (a:b:c:d:xs) = (a,b,c,d) : group4 xs- group4 _ = []- - let v' = V.fromList- $ concat- $ [ let brightness = round- ( 0.34 * fromIntegral r - + 0.5 * fromIntegral g- + 0.16 * fromIntegral b :: Double)- in [brightness,brightness,brightness,a] - | (r,g,b,a) <- group4 $ V.toList $ v- ]- - send context $ do- putImageData (ImageData w h v', [100,100])- - wiki $ snapShot context "images/Grayscale.png"- wiki $ close context
− wiki-suite/Image_Crop.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Image_Crop where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = do- blankCanvas 3000 $ \ context -> do- send context $ do- img <- newImage "images/Haskell.jpg"- drawImage(img,[150,0,150,150,50,50,150,200])- - - wiki $ snapShot context "images/Image_Crop.png"- wiki $ close context
− wiki-suite/Image_Loader.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Image_Loader where--import Graphics.Blank-import Wiki -- (578,400)--main :: IO ()-main = do- blankCanvas 3000 $ \ context -> do- send context $ do- img1 <- newImage "images/Haskell.jpg"- img2 <- newImage "images/House.jpg"- drawImage(img1,[69,50,97,129])- drawImage(img2,[200,50])- - - wiki $ snapShot context "images/Image_Loader.png"- wiki $ close context
− wiki-suite/Image_Size.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Image_Size where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = do- blankCanvas 3000 $ \ context -> do- send context $ do- img <- newImage "images/Haskell.jpg"- drawImage(img,[69,50,97,129])- - - wiki $ snapShot context "images/Image_Size.png"- wiki $ close context
− wiki-suite/Is_Point_In_Path.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Is_Point_In_Path where--import Graphics.Blank-import Wiki -- (400,400)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do-- send context $ do- strokeStyle "blue";- beginPath();- rect(100,100,200,200)- cmds <- sequence [ do- b <- isPointInPath (x,y)- return $ do- beginPath()- fillStyle $ if b then "red" else "green"- arc(x, y, 5, 0, pi*2, False)- fill()- | x <- take 8 [25,25+50..]- , y <- take 8 [25,25+50..]- ]- stroke()- -- Now draw the points- sequence_ cmds-- wiki $ snapShot context "images/Is_Point_In_Path.png"- wiki $ close context
− wiki-suite/Key_Read.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Key_Read where--import Data.List (nub)-import Data.Monoid ((<>))-import qualified Data.Text as Text--- import Debug.Trace-import Graphics.Blank-import Wiki -- (512,200)--data State = State- { keys :: [Int] -- key *codes* for pressed keys- , step :: Int- }- deriving Show--main :: IO ()-main = blankCanvas 3000 { events = ["keyup","keydown"] } $ \ context -> loop context (State [] 0)--loop :: DeviceContext -> State -> IO ()-loop context state = do- send context $ do- clearRect (0,0,width context,height context)- lineWidth 1- strokeStyle "red"- font "30pt Calibri"- fillText("Keys currently pressed: " <> Text.pack (show (keys state)),10,50)- fillText("Counter: " <> Text.pack (show (step state)),10,150)-- control context state--control :: DeviceContext -> State -> IO ()-control context state = do- wiki $ counter (\ _ -> True) $ \ n -> do- file <- wiki $ anim_png "Key_Read"- wiki $ snapShot context $ file- wiki $ whenM (n == 1) $ ev context "keydown" 90- wiki $ whenM (n == 2) $ ev context "keydown" 88- wiki $ whenM (n == 3) $ ev context "keyup" 88- wiki $ whenM (n == 4) $ ev context "keyup" 90- wiki $ whenM (n == 5) $ do { build_anim "Key_Read" 100; close context }- event <- wait context- print event- let down_keys = case (eType event,eWhich event) of- ("keydown",Just c) -> [c]- _ -> []- let up_keys = case (eType event,eWhich event) of- ("keyup",Just c) -> [c]- _ -> []- let current_keys = [ k | k <- nub (keys state ++ down_keys), not (k `elem` up_keys) ]- let state' = state { step = step state + 1, keys = current_keys }- loop context state'
− wiki-suite/Line.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Line where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath()- moveTo(100,150)- lineTo(450,50)- stroke()--- wiki $ snapShot context "images/Line.png"- wiki $ close context
− wiki-suite/Line_Cap.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Line_Cap where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- sequence_- [ do beginPath()- moveTo(200, height context / 2 + n)- lineTo(width context - 200, height context / 2 + n)- lineWidth 20- strokeStyle "#0000ff"- lineCap cap- stroke()- | (cap,n) <- zip ["butt","round","square"] [-50,0,50]- ]--- wiki $ snapShot context "images/Line_Cap.png"- wiki $ close context
− wiki-suite/Line_Color.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Line_Color where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- moveTo(100,150)- lineTo(450,50)- lineWidth 5- strokeStyle "#ff0000"- stroke()--- wiki $ snapShot context "images/Line_Color.png"- wiki $ close context
− wiki-suite/Line_Join.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Line_Join where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- - lineWidth 25;-- -- miter line join (left)- beginPath();- moveTo(99, 150);- lineTo(149, 50);- lineTo(199, 150);- lineJoin "miter";- stroke();-- -- round line join (middle)- beginPath();- moveTo(239, 150);- lineTo(289, 50);- lineTo(339, 150);- lineJoin "round";- stroke();-- -- bevel line join (right)- beginPath();- moveTo(379, 150);- lineTo(429, 50);- lineTo(479, 150);- lineJoin "bevel";- stroke();- -- wiki $ snapShot context "images/Line_Join.png"- wiki $ close context
− wiki-suite/Line_Width.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Line_Width where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- moveTo(100,150)- lineTo(450,50)- lineWidth 15- stroke()--- wiki $ snapShot context "images/Line_Width.png"- wiki $ close context
− wiki-suite/Linear_Gradient.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Linear_Gradient where--import Graphics.Blank-import qualified Graphics.Blank.Style as Style-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do - rect(0, 0, width context, height context)- grd <- createLinearGradient(0, 0, width context, height context)- -- light blue- grd # addColorStop(0, "#8ED6FF")- -- dark blue- grd # addColorStop(1, "#004CB3")- Style.fillStyle grd;- fill();--- wiki $ snapShot context "images/Linear_Gradient.png"- wiki $ close context
− wiki-suite/Load_Image_Data_URL.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Load_Image_Data_URL where--import qualified Data.Text.IO as Text.IO-import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = do- blankCanvas 3000 $ \ context -> do- url <- Text.IO.readFile "data/dataURL.txt"- send context $ do- img <- newImage url- drawImage (img,[0,0])- - wiki $ snapShot context "images/Load_Image_Data_URL.png"- wiki $ close context
− wiki-suite/Load_Image_Data_URL_2.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Load_Image_Data_URL_2 where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- url <- readDataURL "image/jpeg" "images/Haskell.jpg"- send context $ do- img <- newImage url- drawImage (img,[0,0])-- wiki $ snapShot context "images/Load_Image_Data_URL_2.png"- wiki $ close context
− wiki-suite/Main.hs
@@ -1,298 +0,0 @@--- Shake Generator for wiki pages-{-# LANGUAGE CPP #-}-module Main where--import Prelude hiding ((*>))--import Control.Concurrent--import Data.Char-import Data.List--import qualified Development.Shake as Shake-import Development.Shake hiding (doesFileExist)-import Development.Shake.FilePath--import System.Directory-import System.Environment-import System.IO-import System.Process---- TO test: ghci wiki-suite/Draw_Canvas.hs -idist/build/autogen/:.:wiki-suite-import qualified Arc-import qualified Bezier_Curve-import qualified Bounce-import qualified Circle-import qualified Clipping_Region-import qualified Color_Fill-import qualified Color_Square-import qualified Custom_Shape-import qualified Draw_Canvas-import qualified Draw_Device-import qualified Draw_Image-import qualified Favicon-import qualified Font_Size_and_Style-import qualified Get_Image_Data_URL-import qualified Global_Alpha-import qualified Global_Composite_Operations-import qualified Grayscale-import qualified Image_Crop-import qualified Image_Loader-import qualified Image_Size-import qualified Is_Point_In_Path-import qualified Key_Read-import qualified Line-import qualified Line_Cap-import qualified Line_Color-import qualified Line_Join-import qualified Line_Width-import qualified Linear_Gradient-import qualified Load_Image_Data_URL-import qualified Load_Image_Data_URL_2-import qualified Miter_Limit-import qualified Path-import qualified Pattern-import qualified Quadratic_Curve-import qualified Radial_Gradient-import qualified Rectangle-import qualified Red_Line-import qualified Rotating_Square-import qualified Rounded_Corners-import qualified Semicircle-import qualified Shadow-import qualified Square-import qualified Text_Align-import qualified Text_Baseline-import qualified Text_Color-import qualified Text_Metrics-import qualified Text_Stroke-import qualified Text_Wrap-import qualified Tic_Tac_Toe-import qualified Translate_Transform-import qualified Scale_Transform-import qualified Rotate_Transform-import qualified Custom_Transform--import System.Environment--main :: IO ()-main = do - args <- getArgs - main2 args--main2 :: [String] -> IO ()-main2 ["Arc"] = Arc.main-main2 ["Bezier_Curve"] = Bezier_Curve.main-main2 ["Bounce"] = Bounce.main-main2 ["Circle"] = Circle.main-main2 ["Clipping_Region"] = Clipping_Region.main-main2 ["Color_Fill"] = Color_Fill.main-main2 ["Color_Square"] = Color_Square.main-main2 ["Custom_Shape"] = Custom_Shape.main-main2 ["Draw_Canvas"] = Draw_Canvas.main-main2 ["Draw_Device"] = Draw_Device.main-main2 ["Draw_Image"] = Draw_Image.main-main2 ["Favicon"] = Favicon.main-main2 ["Font_Size_and_Style"] = Font_Size_and_Style.main-main2 ["Get_Image_Data_URL"] = Get_Image_Data_URL.main-main2 ["Global_Alpha"] = Global_Alpha.main-main2 ["Global_Composite_Operations"] = Global_Composite_Operations.main-main2 ["Grayscale"] = Grayscale.main-main2 ["Image_Crop"] = Image_Crop.main-main2 ["Image_Loader"] = Image_Loader.main-main2 ["Miter_Limit"] = Miter_Limit.main-main2 ["Image_Size"] = Image_Size.main-main2 ["Is_Point_In_Path"] = Is_Point_In_Path.main-main2 ["Key_Read"] = Key_Read.main-main2 ["Line"] = Line.main-main2 ["Line_Cap"] = Line_Cap.main-main2 ["Line_Color"] = Line_Color.main-main2 ["Line_Join"] = Line_Join.main-main2 ["Line_Width"] = Line_Width.main-main2 ["Linear_Gradient"] = Linear_Gradient.main-main2 ["Load_Image_Data_URL"] = Load_Image_Data_URL.main-main2 ["Load_Image_Data_URL_2"] = Load_Image_Data_URL_2.main-main2 ["Path"] = Path.main-main2 ["Pattern"] = Pattern.main-main2 ["Quadratic_Curve"] = Quadratic_Curve.main-main2 ["Radial_Gradient"] = Radial_Gradient.main-main2 ["Rectangle"] = Rectangle.main-main2 ["Red_Line"] = Red_Line.main-main2 ["Rotating_Square"] = Rotating_Square.main-main2 ["Rounded_Corners"] = Rounded_Corners.main-main2 ["Semicircle"] = Semicircle.main-main2 ["Shadow"] = Shadow.main-main2 ["Square"] = Square.main-main2 ["Text_Align"] = Text_Align.main-main2 ["Text_Baseline"] = Text_Baseline.main-main2 ["Text_Color"] = Text_Color.main-main2 ["Text_Metrics"] = Text_Metrics.main-main2 ["Text_Stroke"] = Text_Stroke.main-main2 ["Text_Wrap"] = Text_Wrap.main-main2 ["Tic_Tac_Toe"] = Tic_Tac_Toe.main-main2 ["Translate_Transform"] = Translate_Transform.main-main2 ["Scale_Transform"] = Scale_Transform.main-main2 ["Rotate_Transform"] = Rotate_Transform.main-main2 ["Custom_Transform"] = Custom_Transform.main--main2 ["clean"] = do - _ <- createProcess $ shell "rm blank-canvas.wiki/images/*.png blank-canvas.wiki/images/*.gif blank-canvas.wiki/examples/*.hs"- return ()- -main2 args = shakeArgs shakeOptions $ do-- if null args then do- want ["blank-canvas.wiki/images/" ++ nm ++ ".gif" | nm <- movies ]- want ["blank-canvas.wiki/images/" ++ nm ++ ".png" | nm <- examples ++ tutorial]- want ["blank-canvas.wiki/examples/" ++ nm ++ ".hs" | nm <- movies ++ examples ++ tutorial]- want ["blank-canvas.wiki/" ++ toMinus nm ++ ".md" | nm <- movies ++ examples ++ tutorial]- else return ()-- ["blank-canvas.wiki/images/*.png", "blank-canvas.wiki/images/*.gif"] |*> \out -> do- let nm = takeBaseName out-- liftIO $ print (out,nm)-- let tmp = "tmp"-- liftIO $ createDirectoryIfMissing False tmp- liftIO $ removeFiles tmp [nm ++ "*.png"]- liftIO $ createDirectoryIfMissing False tmp-- need [ "blank-canvas.wiki/" ++ toMinus nm ++ ".md" ]- let haskell_file = nm ++ ".hs"- need [ "wiki-suite/" ++ haskell_file, "blank-canvas.wiki/examples/" ++ haskell_file ] - liftIO $ print nm-- txt <- readFile' $ "wiki-suite/" ++ haskell_file-- let (w,h) = head $- [ case words ln of- [_,_,_,n] -> read n- _ -> (512,384)- | ln <- lines txt - , "import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln- ] ++ [(512,384) :: (Int, Int)]--- sequence_ [- do (_,_,_,ghc) <- liftIO $ - createProcess (proc "./dist/build/wiki-suite/wiki-suite" [nm])-- -- wait a second, for things to start- liftIO $ threadDelay (1 * 1000 * 1000)- -#if defined(darwin_HOST_OS)- command_ [] "/usr/bin/open" - ["-a"- ,"/Applications/Google Chrome.app"- ,"http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd]-#else- -- TODO: Figure out what Windows/MinTTY uses- command_ [] "/usr/bin/xdg-open" ["http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd]-#endif- -- wait for haskell program to stop- liftIO $ waitForProcess ghc | hd <- [("")] ++ if nm == "Text_Wrap" then [("&hd")] else [] ]- return ()--- "blank-canvas.wiki/examples/*.hs" *> \ out -> do- liftIO $ print out- let haskell_file = takeFileName out-- txt <- readFile' $ "./wiki-suite/" ++ haskell_file-- let new = reverse- $ dropWhile (all isSpace)- $ reverse- [ if "module" `isPrefixOf` ln - then "module Main where"- else ln- | ln <- lines txt - , not ("wiki $" `isInfixOf` ln) -- remove the wiki stuff- , not ("import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln)- ]-- writeFileChanged out (unlines $ map (untabify 0) new)-- "blank-canvas.wiki/*.md" *> \ out -> do- b <- Shake.doesFileExist out--- liftIO $ print b- txts <- liftIO $ if b then do- h <- openFile out ReadMode- let loop = do- b' <- hIsEOF h - if b'- then return []- else do- ln <- hGetLine h- lns <- loop- return (ln : lns)- txts <- loop - hClose h- return txts- else return [] --- liftIO $ print txts-- let p = not . (code_header `isPrefixOf`)- let textToKeep = takeWhile p txts-- let haskell_file = map (\ c -> if c == '-' then '_' else c) - $ replaceExtension (takeFileName out) ".hs"--- liftIO $ print haskell_file- txt <- readFile' $ "blank-canvas.wiki/examples/" ++ haskell_file -- let new = unlines $- [ t | t <- textToKeep - ] ++- [code_header] ++- lines txt ++- [code_footer]---- liftIO $ putStrLn new-- writeFileChanged out new----- to clean: rm images/*png images/*gif examples/*hs--- */--movies :: [String]-movies = ["Rotating_Square","Tic_Tac_Toe","Bounce","Key_Read","Square"]--examples :: [String]-examples = ["Red_Line","Favicon"]- ++ ["Color_Square"] --tutorial :: [String]-tutorial = ["Line", "Line_Width", "Line_Color", "Line_Cap","Miter_Limit"]- ++ ["Arc","Quadratic_Curve","Bezier_Curve"]- ++ ["Path","Line_Join","Rounded_Corners","Is_Point_In_Path"]- ++ ["Custom_Shape","Rectangle","Circle","Semicircle"]- ++ ["Color_Fill","Linear_Gradient","Radial_Gradient","Pattern"]- ++ ["Draw_Image","Image_Size","Image_Crop","Image_Loader", "Draw_Canvas", "Draw_Device"]- ++ ["Font_Size_and_Style","Text_Color","Text_Stroke","Text_Align","Text_Baseline","Text_Metrics","Text_Wrap"]- ++ ["Translate_Transform","Scale_Transform","Rotate_Transform","Custom_Transform"]- ++ ["Shadow","Global_Alpha","Clipping_Region","Global_Composite_Operations"]- ++ ["Grayscale","Get_Image_Data_URL","Load_Image_Data_URL"]- ++ ["Load_Image_Data_URL_2"]--wiki_dir :: String-wiki_dir = "."--toMinus :: String -> String-toMinus = map (\ c -> if c == '_' then '-' else c) ---untabify :: Int -> String -> String-untabify _ [] = []-untabify n (c:cs) | c == '\t' = let t = 8 - n `mod` 8 in take t (cycle " ") ++ untabify (n + t) cs- | otherwise = c : untabify (n + 1) cs --code_header :: String-code_header = "````Haskell"--code_footer :: String-code_footer = "````"
− wiki-suite/Miter_Limit.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Miter_Limit where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- clearRect(0,0,150,150);- -- Draw guides- strokeStyle "#09f";- lineWidth 2;- strokeRect(-5,50,160,50);- - -- Set line styles- strokeStyle "#000";- lineWidth 10;- - -- check input- miterLimit 5;-- -- Draw lines- beginPath()- moveTo(0,100)- sequence_ [ lineTo((fromIntegral i ** 1.5)*2,75+(if i `mod` 2 == 0 then 25 else -25))- | i <- [0..20] :: [Int]- ]- stroke();-- wiki $ snapShot context "images/Miter_Limit.png"- wiki $ close context
− wiki-suite/Path.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Path where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath()- moveTo(100, 20)- -- line 1- lineTo(200, 160)- -- quadratic curve- quadraticCurveTo(230, 200, 250, 120)- -- bezier curve- bezierCurveTo(290, -40, 300, 200, 400, 150)- -- line 2- lineTo(500, 90)- lineWidth 5- strokeStyle "blue"- stroke()---- wiki $ snapShot context "images/Path.png"- wiki $ close context
− wiki-suite/Pattern.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Pattern where--import Graphics.Blank-import qualified Graphics.Blank.Style as Style-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- imageObj <- newImage "images/Haskell.jpg"- pattern <- createPattern (imageObj,"repeat")- rect(0, 0, width context, height context);- Style.fillStyle pattern;- fill();--- wiki $ snapShot context "images/Pattern.png"- wiki $ close context
− wiki-suite/Quadratic_Curve.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Quadratic_Curve where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath()- moveTo(188, 150)- quadraticCurveTo(288, 0, 388, 150)- lineWidth 10- -- line color- strokeStyle "black"- stroke()--- wiki $ snapShot context "images/Quadratic_Curve.png"- wiki $ close context
− wiki-suite/Radial_Gradient.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Radial_Gradient where--import Graphics.Blank-import qualified Graphics.Blank.Style as Style-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- rect(0, 0, width context, height context)- grd <- createRadialGradient (238, 50, 10, 238, 50, 300)- -- light blue- grd # addColorStop(0, "#8ED6FF")- -- dark blue- grd # addColorStop(1, "#004CB3")- Style.fillStyle grd;- fill();--- wiki $ snapShot context "images/Radial_Gradient.png"- wiki $ close context
− wiki-suite/Rectangle.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Rectangle where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath();- rect(188, 50, 200, 100);- fillStyle "yellow";- fill();- lineWidth 7;- strokeStyle "black";- stroke();- -- wiki $ snapShot context "images/Rectangle.png"- wiki $ close context
− wiki-suite/Red_Line.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Red_Line where--import Graphics.Blank -- import the blank canvas-import Wiki -- (600,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000- send context $ do -- send commands to this specific context- moveTo(50,50)- lineTo(200,100)- lineWidth 10- strokeStyle "red"- stroke() -- this draws the ink into the canvas-- wiki $ snapShot context "images/Red_Line.png"- wiki $ close context
− wiki-suite/Rotate_Transform.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Rotate_Transform where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let rectWidth = 150;- let rectHeight = 75;- translate(width context / 2, height context / 2);- rotate (pi/4);-- fillStyle "blue";- fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);--- wiki $ snapShot context "images/Rotate_Transform.png"- wiki $ close context
− wiki-suite/Rotating_Square.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Rotating_Square where--import Control.Concurrent-import Graphics.Blank-import Wiki -- (384,384)--main :: IO ()-main = blankCanvas 3000 $ flip loop 0--loop :: DeviceContext -> Double -> IO ()-loop context n = do- send context $ do- clearRect (0,0,width context,height context)- beginPath()- save()- translate (width context / 2,height context / 2)- rotate (pi * n)- beginPath()- moveTo(-100,-100)- lineTo(-100,100)- lineTo(100,100)- lineTo(100,-100)- closePath()- lineWidth 10- strokeStyle "green"- stroke()- restore()- threadDelay (20 * 1000)- v <- wiki $ return (round (n*100) :: Int)- wiki $ whenM (v `mod` 2 == 0) $ do- file <- wiki $ anim_png "Rotating_Square"- wiki $ snapShot context $ file- wiki $ whenM (v == 48) $ do { build_anim "Rotating_Square" 5; close context }- loop context (n + 0.01)-
− wiki-suite/Rounded_Corners.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Rounded_Corners where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- - lineWidth 25;-- let rectWidth = 200;- let rectHeight = 100;- let rectX = 189;- let rectY = 50;- let cornerRadius = 50;-- beginPath();- moveTo(rectX, rectY);- lineTo(rectX + rectWidth - cornerRadius, rectY);- arcTo(rectX + rectWidth, rectY, rectX + rectWidth, rectY + cornerRadius, cornerRadius);- lineTo(rectX + rectWidth, rectY + rectHeight);- lineWidth 5;- stroke();--- wiki $ snapShot context "images/Rounded_Corners.png"- wiki $ close context
− wiki-suite/Scale_Transform.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Scale_Transform where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let rectWidth = 150;- let rectHeight = 75;- translate(width context / 2, height context / 2);- scale(1, 0.5);-- fillStyle "blue";- fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);--- wiki $ snapShot context "images/Scale_Transform.png"- wiki $ close context
− wiki-suite/Semicircle.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Semicircle where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- beginPath();- arc(288, 75, 70, 0, pi, False);- closePath();- lineWidth 5;- fillStyle "red";- fill();- strokeStyle "#550000";- stroke();--- wiki $ snapShot context "images/Semicircle.png"- wiki $ close context
− wiki-suite/Shadow.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Shadow where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- rect(188, 40, 200, 100);- fillStyle "red";- shadowColor "#999";- shadowBlur 20;- shadowOffsetX 15;- shadowOffsetY 15;- fill()--- wiki $ snapShot context "images/Shadow.png"- wiki $ close context
− wiki-suite/Square.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Square where--import Graphics.Blank-import Wiki -- (512,512)--main :: IO ()-main = blankCanvas 3000 { events = ["mousedown"] } $ \ context -> do- let loop (x,y) (color:colors) = do- send context $ saveRestore $ do- translate (x,y)- beginPath()- moveTo(-100,-100)- lineTo(-100,100)- lineTo(100,100)- lineTo(100,-100)- closePath()- lineWidth 10- strokeStyle color- stroke()--- wiki $ counter (\ _ -> True) $ \ n -> do- file <- wiki $ anim_png "Square"- wiki $ snapShot context $ file- let e (x',y') = wiki $ send context $ trigger $ Event {- eMetaKey = False- , ePageXY = return (x',y')- , eType = "mousedown"- , eWhich = Nothing- }- wiki $ whenM (n == 1) $ e (x-100,y+50)- wiki $ whenM (n == 2) $ e (x+20, y-60)- wiki $ whenM (n == 3) $ e (x+40, y+20)- wiki $ whenM (n == 4) $ e (x+60, y-60)- wiki $ whenM (n >= 5) $ do { build_anim "Square" 100; close context }-- event <- wait context- case ePageXY event of- Nothing -> loop (x,y) colors- Just (x',y') -> loop (x',y') colors-- putStrLn "calling size" - loop (width context / 2,height context / 2)- (cycle [ "#749871", "#1887f2", "#808080", "f01234"])----
− wiki-suite/Text_Align.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text_Align where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let x = width context / 2- let y = height context / 2- font "30pt Calibri"- textAlign "center"- fillStyle "blue"- fillText("Hello World!", x, y)--- wiki $ snapShot context "images/Text_Align.png"- wiki $ close context
− wiki-suite/Text_Baseline.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text_Baseline where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let x = width context / 2- let y = height context / 2- font "30pt Calibri"- textAlign "center"- textBaseline "middle"- fillStyle "blue"- fillText("Hello World!", x, y)--- wiki $ snapShot context "images/Text_Baseline.png"- wiki $ close context
− wiki-suite/Text_Color.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text_Color where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- font "40pt Calibri"- fillStyle "#0000ff"- fillText("Hello World!", 150, 100)--- wiki $ snapShot context "images/Text_Color.png"- wiki $ close context
− wiki-suite/Text_Metrics.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text_Metrics where--import Data.Monoid-import qualified Data.Text as Text-import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do - let x = width context / 2- let y = height context / 2 - 10;- let text = "Hello World!"- font "30pt Calibri"- textAlign "center"- fillStyle "blue"- fillText(text, x, y)-- TextMetrics w <- measureText text- font "20pt Calibri"- textAlign "center"- fillStyle "#555"- fillText("(" <> Text.pack (show w) <> "px wide)", x, y + 40)--- wiki $ snapShot context "images/Text_Metrics.png"- wiki $ close context
− wiki-suite/Text_Stroke.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text_Stroke where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- font "60pt Calibri"- lineWidth 3- strokeStyle "blue"- strokeText("Hello World!", 80, 110)--- wiki $ snapShot context "images/Text_Stroke.png"- wiki $ close context
− wiki-suite/Text_Wrap.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text_Wrap where--import Data.Monoid-import qualified Data.Text as Text-import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- let r = devicePixelRatio context- send context $ do- font $ Text.pack $ "lighter " ++ show (16 * r) ++ "pt Calibri"- fillStyle "#000"- let maxWidth = 400 * r- wrapText 0 (Text.words message) ((width context - maxWidth) / 2) 60 maxWidth (25 * r)- let ex = wiki $ if r > 1.5 then "@2x" else ""- wiki $ snapShot context $ "images/Text_Wrap" ++ ex ++ ".png"- wiki $ close context- where-- message = "All the world's a stage, and all the men and women merely players. " <>- "They have their exits and their entrances; And one man in his time plays many parts."-- wrapText _ [] _ _ _ _ = return ()- wrapText wc text x y maxWidth lineHeight = do- TextMetrics testWidth <- measureText $ Text.unwords $ take (wc+1) $ text- if (testWidth > maxWidth && wc > 0) || length text <= wc- then do fillText(Text.unwords $ take wc $ text,x,y)- wrapText 0 (drop wc text) x (y + lineHeight) maxWidth lineHeight- else do wrapText (wc+1) text x y maxWidth lineHeight---
− wiki-suite/Tic_Tac_Toe.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Tic_Tac_Toe where--import Control.Concurrent -- wiki $--import qualified Data.Map as Map-import Data.Map (Map)-import Data.Text (Text)---- import Debug.Trace--import Graphics.Blank--import Wiki -- (512,384)--main :: IO ()-main = blankCanvas 3000 { events = ["mousedown"] } $ \ context -> loop context Map.empty X--data XO = X | O deriving (Eq,Ord,Show)--swap :: XO -> XO-swap X = O-swap O = X--loop :: DeviceContext -> Map (Int, Int) XO -> XO -> IO ()-loop context board turn = do- sz <- send context $ do- clearRect (0,0,width context,height context)- beginPath()-- let sz = min (width context) (height context)- save()- translate (width context / 2,height context / 2)- sequence_ [ do bigLine (-sz * 0.45,n) (sz * 0.45,n)- bigLine (n,-sz * 0.45) (n,sz * 0.45)- | n <- [-sz * 0.15,sz * 0.15]- ]--- sequence_ [ do save()- translate (fromIntegral x * sz * 0.3,fromIntegral y * sz * 0.3)- case Map.lookup (x,y) board of- Just X -> drawX (sz * 0.1)- Just O -> drawO (sz * 0.1)- Nothing -> return ()- restore()- | x <- [-1,0,1]- , y <- [-1,0,1]- ]- restore()- return sz-- let pointToSq :: (Double, Double) -> Maybe (Int, Int)- pointToSq (x,y) = do- x' <- fd ((x - width context / 2) / sz)- y' <- fd ((y - height context / 2) / sz)- return (x',y')-- fd x = --- trace (show ("fx",x,r)) $- if r `elem` [-1..1] then Just (signum r) else Nothing- where r = round (x * 3.3333)-- let press = (width context / 2 + fromIntegral x * (sz / 4),height context / 2 + fromIntegral y * (sz / 4)) -- wiki $- where (x,y) = head [ ix | (ix,Nothing) -- wiki $- <- [ ((x',y'),Map.lookup (x',y') board) -- wiki $- | y' <- [-1,0,1] -- wiki $- , x' <- [-1,0,1] -- wiki $- ]] -- wiki $-- _ <- wiki $ forkIO $ send context $ trigger $ Event {- eMetaKey = False- , ePageXY = return $ press- , eType = "keypress"- , eWhich = Nothing- }- event <- wait context-- file <- wiki $ anim_png "Tic_Tac_Toe"- wiki $ snapShot context $ file- wiki $ whenM (Map.size board == 7) $ do { build_anim "Tic_Tac_Toe" 100; close context ; quit }-- print event- case ePageXY event of- -- if no mouse location, ignore, and redraw- Nothing -> loop context board turn- Just (x',y') -> case pointToSq (x',y') of- Nothing -> loop context board turn- Just pos -> case Map.lookup pos board of- Nothing -> loop context- (Map.insert pos turn board)- (swap turn)- -- already something here- Just _ -> loop context board turn--xColor, oColor, boardColor :: Text-xColor = "#ff0000"-oColor = "#00a000"-boardColor = "#000080"--drawX :: Double -> Canvas ()-drawX size = do- strokeStyle xColor- lineCap "butt"- beginPath()- moveTo(-size,-size)- lineTo(size,size)- lineWidth 10- stroke()- beginPath()- moveTo(-size,size)- lineTo(size,-size)- lineWidth 10- stroke()--drawO :: Double -> Canvas ()-drawO radius = do- beginPath()- arc(0, 0, radius, 0, 2 * pi, False)- lineWidth 10- strokeStyle oColor- stroke()--bigLine :: (Double, Double) -> (Double, Double) -> Canvas ()-bigLine (x,y) (x',y') = do- beginPath()- moveTo(x,y)- lineTo(x',y')- lineWidth 20- strokeStyle boardColor- lineCap "round"- stroke()
− wiki-suite/Translate_Transform.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Translate_Transform where--import Graphics.Blank-import Wiki -- (578,200)--main :: IO ()-main = blankCanvas 3000 $ \ context -> do- send context $ do- let rectWidth = 150;- let rectHeight = 75;- translate(width context / 2, height context / 2);- fillStyle "blue";- fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);--- wiki $ snapShot context "images/Translate_Transform.png"- wiki $ close context
− wiki-suite/Wiki.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- wiki generator support--module Wiki where--import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Monad as M--import Data.Text (Text)-import Data.Time.Clock.POSIX--import Graphics.Blank--import System.Exit-import System.IO.Unsafe-import System.Posix.Process-import System.Process--import Text.Printf---- import Trace.Hpc.Reflect--- import Trace.Hpc.Tix--snapShot :: DeviceContext -> FilePath -> IO ()-snapShot context fileName = do- txt <- send context $ do-- tempCanvas <- newCanvas (round (width context + 20 :: Double),- round (height context + 20 :: Double))-- top' <- myCanvasContext-- with tempCanvas $ do- -- print a border, because we can (looks better in wiki)-- save()- beginPath()- moveTo(1,1)- lineTo(width context+1,1)- lineTo(width context+1,height context+1)- lineTo(1,height context+1)- closePath()- fillStyle "white"-- shadowOffsetX 10- shadowOffsetY 10;- shadowBlur 15;- shadowColor "#999";-- fill()-- beginPath()- moveTo(0.5,0.5)- lineTo(width context+1.5,0.5)- lineTo(width context+1.5,height context+1.5)- lineTo(0.5,height context+1.5)- closePath()-- shadowOffsetX 0- shadowOffsetY 0- shadowBlur 0- lineWidth 1- strokeStyle "black"-- stroke()-- restore()- - drawImage(top',[1,1])- toDataURL() -- of tempCanvas-- writeDataURL ("blank-canvas.wiki/" ++ fileName) txt--wiki :: a -> a-wiki = id--close :: DeviceContext -> IO ()-close context = do--- n <- getPOSIXTime --- Tix tix <- examineTix--- let tix' = filter (\ t -> ("Graphics.Blank" `isPrefixOf` tixModuleName t)) --- $ tix--- writeFile ("tix/tix_" ++ printf "_%013d" (floor (fromRational (toRational n) * 1000) :: Integer) ++ ".tix") $ show $ Tix tix'- send context $ eval "open(location, '_self').close()"- threadDelay (1000 * 1000);- putStrLn "dieing"- p <- getProcessID - callProcess "kill" [show p]- quit--quit :: IO a-quit = exitSuccess--whenM :: Monad m => Bool -> m () -> m ()-whenM = M.when--anim_png :: String -> IO String-anim_png nm = do- n <- getPOSIXTime - return $ "tmp/" ++ nm ++ printf "_%013d" (floor (fromRational (toRational n) * 1000 :: Double) :: Integer) ++ ".png"--build_anim :: String -> Int -> IO ()-build_anim nm pz = do- callCommand $ "convert -delay " ++ show pz ++ " -loop 0 -dispose background blank-canvas.wiki/tmp/" ++ nm ++ "_*.png blank-canvas.wiki/images/" ++ nm ++ ".gif"- return ()---{-# NOINLINE count #-}-count :: TVar Int-count = unsafePerformIO $ newTVarIO 1--counter :: (Int -> Bool) -> (Int -> IO ()) -> IO ()-counter p k = do- n <- atomically $ do- v <- readTVar count- writeTVar count $! v + 1- return v- if p n then k n else return ()---ev :: DeviceContext -> Text -> Int -> IO ()-ev context t c = send context $ trigger $ Event { eMetaKey = False, ePageXY = Nothing, eType = t, eWhich = Just c }