blank-canvas 0.7 → 0.7.1
raw patch · 58 files changed
+10/−2004 lines, 58 filesdep −blank-canvasdep −directorydep −processdep ~aesondep ~basedep ~base64-bytestringPVP ok
version bump matches the API change (PVP)
Dependencies removed: blank-canvas, directory, process, shake, time, unix
Dependency ranges changed: aeson, base, base64-bytestring, scotty
API changes (from Hackage documentation)
Files
- Changelog.md +6/−0
- LICENSE +1/−1
- blank-canvas.cabal +3/−79
- 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/−53
- 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/−29
- wiki-suite/Text_Stroke.hs +0/−17
- wiki-suite/Text_Wrap.hs +0/−35
- 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,9 @@+## 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`.
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.7+Version: 0.7.1 Synopsis: HTML5 Canvas Graphics Library Description: @blank-canvas@ is a Haskell binding to the complete@@ -76,8 +76,8 @@ default-language: Haskell2010 build-depends: aeson >= 0.7 && < 1.5, base64-bytestring == 1.0.*,- base >= 4.7 && < 4.14,- base-compat-batteries >= 0.10 && < 0.11,+ base >= 4.7 && < 4.15,+ base-compat-batteries >= 0.10 && < 0.12, bytestring == 0.10.*, colour >= 2.2 && < 2.4, containers >= 0.5 && < 0.7,@@ -99,82 +99,6 @@ GHC-options: -Wall GHC-prof-options: -Wall -fsimpl-tick-factor=100000---test-suite wiki-suite- build-depends: base >= 4.7 && < 4.14,- base-compat-batteries >= 0.10 && < 0.11,- blank-canvas,- containers >= 0.5 && < 0.7,- process >= 1.2 && < 1.7,- directory >= 1.2,- shake >= 0.14,- stm >= 2.2 && < 2.6,- text >= 1.1 && < 1.3,- time >= 1.4 && < 1.10,- unix >= 2.7 && < 2.8,- vector >= 0.10 && < 0.13-- 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
− 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,53 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Key_Read where--import Data.List (nub)-import qualified Data.Text as Text--- import Debug.Trace-import Graphics.Blank-import Prelude.Compat-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,29 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Text_Metrics where--import qualified Data.Text as Text-import Graphics.Blank-import Prelude.Compat-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,35 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Text_Wrap where--import qualified Data.Text as Text-import Graphics.Blank-import Prelude.Compat-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 }