diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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` diff --git a/Graphics/Blank.hs b/Graphics/Blank.hs --- a/Graphics/Blank.hs +++ b/Graphics/Blank.hs @@ -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. diff --git a/Graphics/Blank/Canvas.hs b/Graphics/Blank/Canvas.hs --- a/Graphics/Blank/Canvas.hs +++ b/Graphics/Blank/Canvas.hs @@ -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__ -- diff --git a/Graphics/Blank/DeviceContext.hs b/Graphics/Blank/DeviceContext.hs --- a/Graphics/Blank/DeviceContext.hs +++ b/Graphics/Blank/DeviceContext.hs @@ -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) diff --git a/Graphics/Blank/Generated.hs b/Graphics/Blank/Generated.hs --- a/Graphics/Blank/Generated.hs +++ b/Graphics/Blank/Generated.hs @@ -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) diff --git a/Graphics/Blank/JavaScript.hs b/Graphics/Blank/JavaScript.hs --- a/Graphics/Blank/JavaScript.hs +++ b/Graphics/Blank/JavaScript.hs @@ -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) diff --git a/Graphics/Blank/Style.hs b/Graphics/Blank/Style.hs --- a/Graphics/Blank/Style.hs +++ b/Graphics/Blank/Style.hs @@ -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 diff --git a/Graphics/Blank/Types/CSS.hs b/Graphics/Blank/Types/CSS.hs --- a/Graphics/Blank/Types/CSS.hs +++ b/Graphics/Blank/Types/CSS.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TypeSynonymInstances #-} module Graphics.Blank.Types.CSS where -import Data.Monoid ((<>)) import Data.String import Graphics.Blank.JavaScript diff --git a/Graphics/Blank/Types/Cursor.hs b/Graphics/Blank/Types/Cursor.hs --- a/Graphics/Blank/Types/Cursor.hs +++ b/Graphics/Blank/Types/Cursor.hs @@ -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 -- . data Cursor = Auto -- ^ The browser determines the cursor to display based on the -- current context. - | Default -- ^ <> + | Default -- ^ <> | None -- ^ No cursor is rendered. - | ContextMenu -- ^ <> - | Help -- ^ <> - | Pointer -- ^ <> - | Progress -- ^ <> - | Wait -- ^ <> - | Cell -- ^ <> - | Crosshair -- ^ <> - | Text -- ^ <> - | VerticalText -- ^ <> - | Alias -- ^ <> - | Copy -- ^ <> - | Move -- ^ <> - | NoDrop -- ^ <> - | NotAllowed -- ^ <> - | AllScroll -- ^ <> - | ColResize -- ^ <> - | RowResize -- ^ <> - | NResize -- ^ <> - | EResize -- ^ <> - | SResize -- ^ <> - | WResize -- ^ <> - | NEResize -- ^ <> - | NWResize -- ^ <> - | SEResize -- ^ <> - | SWResize -- ^ <> - | EWResize -- ^ <> - | NSResize -- ^ <> - | NESWResize -- ^ <> - | NWSEResize -- ^ <> - | ZoomIn -- ^ <> - | ZoomOut -- ^ <> - | Grab -- ^ <> - | Grabbing -- ^ <> + | ContextMenu -- ^ <> + | Help -- ^ <> + | Pointer -- ^ <> + | Progress -- ^ <> + | Wait -- ^ <> + | Cell -- ^ <> + | Crosshair -- ^ <> + | Text -- ^ <> + | VerticalText -- ^ <> + | Alias -- ^ <> + | Copy -- ^ <> + | Move -- ^ <> + | NoDrop -- ^ <> + | NotAllowed -- ^ <> + | AllScroll -- ^ <> + | ColResize -- ^ <> + | RowResize -- ^ <> + | NResize -- ^ <> + | EResize -- ^ <> + | SResize -- ^ <> + | WResize -- ^ <> + | NEResize -- ^ <> + | NWResize -- ^ <> + | SEResize -- ^ <> + | SWResize -- ^ <> + | EWResize -- ^ <> + | NSResize -- ^ <> + | NESWResize -- ^ <> + | NWSEResize -- ^ <> + | ZoomIn -- ^ <> + | ZoomOut -- ^ <> + | Grab -- ^ <> + | Grabbing -- ^ <> | 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 diff --git a/Graphics/Blank/Types/Font.hs b/Graphics/Blank/Types/Font.hs --- a/Graphics/Blank/Types/Font.hs +++ b/Graphics/Blank/Types/Font.hs @@ -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' } -- @ diff --git a/Graphics/Blank/Utils.hs b/Graphics/Blank/Utils.hs --- a/Graphics/Blank/Utils.hs +++ b/Graphics/Blank/Utils.hs @@ -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') diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2015, The University of Kansas +Copyright (c) 2012-2020, The University of Kansas All rights reserved. diff --git a/blank-canvas.cabal b/blank-canvas.cabal --- a/blank-canvas.cabal +++ b/blank-canvas.cabal @@ -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 diff --git a/wiki-suite/Arc.hs b/wiki-suite/Arc.hs deleted file mode 100644 --- a/wiki-suite/Arc.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Bezier_Curve.hs b/wiki-suite/Bezier_Curve.hs deleted file mode 100644 --- a/wiki-suite/Bezier_Curve.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Bounce.hs b/wiki-suite/Bounce.hs deleted file mode 100644 --- a/wiki-suite/Bounce.hs +++ /dev/null @@ -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"]) diff --git a/wiki-suite/Circle.hs b/wiki-suite/Circle.hs deleted file mode 100644 --- a/wiki-suite/Circle.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Clipping_Region.hs b/wiki-suite/Clipping_Region.hs deleted file mode 100644 --- a/wiki-suite/Clipping_Region.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Color_Fill.hs b/wiki-suite/Color_Fill.hs deleted file mode 100644 --- a/wiki-suite/Color_Fill.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Color_Square.hs b/wiki-suite/Color_Square.hs deleted file mode 100644 --- a/wiki-suite/Color_Square.hs +++ /dev/null @@ -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 - diff --git a/wiki-suite/Custom_Shape.hs b/wiki-suite/Custom_Shape.hs deleted file mode 100644 --- a/wiki-suite/Custom_Shape.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Custom_Transform.hs b/wiki-suite/Custom_Transform.hs deleted file mode 100644 --- a/wiki-suite/Custom_Transform.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Draw_Canvas.hs b/wiki-suite/Draw_Canvas.hs deleted file mode 100644 --- a/wiki-suite/Draw_Canvas.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Draw_Device.hs b/wiki-suite/Draw_Device.hs deleted file mode 100644 --- a/wiki-suite/Draw_Device.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Draw_Image.hs b/wiki-suite/Draw_Image.hs deleted file mode 100644 --- a/wiki-suite/Draw_Image.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Favicon.hs b/wiki-suite/Favicon.hs deleted file mode 100644 --- a/wiki-suite/Favicon.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Font_Size_and_Style.hs b/wiki-suite/Font_Size_and_Style.hs deleted file mode 100644 --- a/wiki-suite/Font_Size_and_Style.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Get_Image_Data_URL.hs b/wiki-suite/Get_Image_Data_URL.hs deleted file mode 100644 --- a/wiki-suite/Get_Image_Data_URL.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Global_Alpha.hs b/wiki-suite/Global_Alpha.hs deleted file mode 100644 --- a/wiki-suite/Global_Alpha.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Global_Composite_Operations.hs b/wiki-suite/Global_Composite_Operations.hs deleted file mode 100644 --- a/wiki-suite/Global_Composite_Operations.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Grayscale.hs b/wiki-suite/Grayscale.hs deleted file mode 100644 --- a/wiki-suite/Grayscale.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Image_Crop.hs b/wiki-suite/Image_Crop.hs deleted file mode 100644 --- a/wiki-suite/Image_Crop.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Image_Loader.hs b/wiki-suite/Image_Loader.hs deleted file mode 100644 --- a/wiki-suite/Image_Loader.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Image_Size.hs b/wiki-suite/Image_Size.hs deleted file mode 100644 --- a/wiki-suite/Image_Size.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Is_Point_In_Path.hs b/wiki-suite/Is_Point_In_Path.hs deleted file mode 100644 --- a/wiki-suite/Is_Point_In_Path.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Key_Read.hs b/wiki-suite/Key_Read.hs deleted file mode 100644 --- a/wiki-suite/Key_Read.hs +++ /dev/null @@ -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' diff --git a/wiki-suite/Line.hs b/wiki-suite/Line.hs deleted file mode 100644 --- a/wiki-suite/Line.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Line_Cap.hs b/wiki-suite/Line_Cap.hs deleted file mode 100644 --- a/wiki-suite/Line_Cap.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Line_Color.hs b/wiki-suite/Line_Color.hs deleted file mode 100644 --- a/wiki-suite/Line_Color.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Line_Join.hs b/wiki-suite/Line_Join.hs deleted file mode 100644 --- a/wiki-suite/Line_Join.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Line_Width.hs b/wiki-suite/Line_Width.hs deleted file mode 100644 --- a/wiki-suite/Line_Width.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Linear_Gradient.hs b/wiki-suite/Linear_Gradient.hs deleted file mode 100644 --- a/wiki-suite/Linear_Gradient.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Load_Image_Data_URL.hs b/wiki-suite/Load_Image_Data_URL.hs deleted file mode 100644 --- a/wiki-suite/Load_Image_Data_URL.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Load_Image_Data_URL_2.hs b/wiki-suite/Load_Image_Data_URL_2.hs deleted file mode 100644 --- a/wiki-suite/Load_Image_Data_URL_2.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Main.hs b/wiki-suite/Main.hs deleted file mode 100644 --- a/wiki-suite/Main.hs +++ /dev/null @@ -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 = "````" diff --git a/wiki-suite/Miter_Limit.hs b/wiki-suite/Miter_Limit.hs deleted file mode 100644 --- a/wiki-suite/Miter_Limit.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Path.hs b/wiki-suite/Path.hs deleted file mode 100644 --- a/wiki-suite/Path.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Pattern.hs b/wiki-suite/Pattern.hs deleted file mode 100644 --- a/wiki-suite/Pattern.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Quadratic_Curve.hs b/wiki-suite/Quadratic_Curve.hs deleted file mode 100644 --- a/wiki-suite/Quadratic_Curve.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Radial_Gradient.hs b/wiki-suite/Radial_Gradient.hs deleted file mode 100644 --- a/wiki-suite/Radial_Gradient.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Rectangle.hs b/wiki-suite/Rectangle.hs deleted file mode 100644 --- a/wiki-suite/Rectangle.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Red_Line.hs b/wiki-suite/Red_Line.hs deleted file mode 100644 --- a/wiki-suite/Red_Line.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Rotate_Transform.hs b/wiki-suite/Rotate_Transform.hs deleted file mode 100644 --- a/wiki-suite/Rotate_Transform.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Rotating_Square.hs b/wiki-suite/Rotating_Square.hs deleted file mode 100644 --- a/wiki-suite/Rotating_Square.hs +++ /dev/null @@ -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) - diff --git a/wiki-suite/Rounded_Corners.hs b/wiki-suite/Rounded_Corners.hs deleted file mode 100644 --- a/wiki-suite/Rounded_Corners.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Scale_Transform.hs b/wiki-suite/Scale_Transform.hs deleted file mode 100644 --- a/wiki-suite/Scale_Transform.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Semicircle.hs b/wiki-suite/Semicircle.hs deleted file mode 100644 --- a/wiki-suite/Semicircle.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Shadow.hs b/wiki-suite/Shadow.hs deleted file mode 100644 --- a/wiki-suite/Shadow.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Square.hs b/wiki-suite/Square.hs deleted file mode 100644 --- a/wiki-suite/Square.hs +++ /dev/null @@ -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"]) - - - - diff --git a/wiki-suite/Text_Align.hs b/wiki-suite/Text_Align.hs deleted file mode 100644 --- a/wiki-suite/Text_Align.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Text_Baseline.hs b/wiki-suite/Text_Baseline.hs deleted file mode 100644 --- a/wiki-suite/Text_Baseline.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Text_Color.hs b/wiki-suite/Text_Color.hs deleted file mode 100644 --- a/wiki-suite/Text_Color.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Text_Metrics.hs b/wiki-suite/Text_Metrics.hs deleted file mode 100644 --- a/wiki-suite/Text_Metrics.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Text_Stroke.hs b/wiki-suite/Text_Stroke.hs deleted file mode 100644 --- a/wiki-suite/Text_Stroke.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Text_Wrap.hs b/wiki-suite/Text_Wrap.hs deleted file mode 100644 --- a/wiki-suite/Text_Wrap.hs +++ /dev/null @@ -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 - - - diff --git a/wiki-suite/Tic_Tac_Toe.hs b/wiki-suite/Tic_Tac_Toe.hs deleted file mode 100644 --- a/wiki-suite/Tic_Tac_Toe.hs +++ /dev/null @@ -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() diff --git a/wiki-suite/Translate_Transform.hs b/wiki-suite/Translate_Transform.hs deleted file mode 100644 --- a/wiki-suite/Translate_Transform.hs +++ /dev/null @@ -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 diff --git a/wiki-suite/Wiki.hs b/wiki-suite/Wiki.hs deleted file mode 100644 --- a/wiki-suite/Wiki.hs +++ /dev/null @@ -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 }