nanovg-0.5.2.0: example/Example.hs
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Applicative (pure)
import Control.Monad
import Control.Monad.Loops
import Control.Monad.Trans.Maybe
import Data.Bits hiding (rotate)
import Data.IORef
import Data.Maybe
import Data.Monoid
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Vector as V
import Graphics.GL.Core32
import Graphics.UI.GLFW hiding (Image)
import NanoVG as NVG
import NanoVG.Internal.Text as Internal
import Prelude hiding (init)
import Foreign.C.Types
import Foreign.Ptr
foreign import ccall unsafe "initGlew"
glewInit :: IO CInt
main :: IO ()
main =
do e <- init
when (not e) $ putStrLn "Failed to init GLFW"
windowHint $ WindowHint'ContextVersionMajor 3
windowHint $ WindowHint'ContextVersionMinor 2
windowHint $ WindowHint'OpenGLForwardCompat True
windowHint $ WindowHint'OpenGLProfile OpenGLProfile'Core
windowHint $ WindowHint'OpenGLDebugContext True
win <- createWindow 1000 600 "NanoVG" Nothing Nothing
case win of
Nothing -> putStrLn "Failed to create window" >> terminate
Just w ->
do makeContextCurrent win
glewInit
glGetError
c@(Context c') <- createGL3 (S.fromList [Antialias,StencilStrokes,Debug])
-- error handling? who needs that anyway
Just demoData <- runMaybeT $ loadDemoData c
swapInterval 0
setTime 0
whileM_ (not <$> windowShouldClose w) $
do Just t <- getTime
(mx,my) <- getCursorPos w
(width,height) <- getWindowSize w
(fbWidth,fbHeight) <- getFramebufferSize w
let pxRatio = fromIntegral fbWidth / fromIntegral width
glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
glClearColor 0.3 0.3 0.32 1.0
glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT .|. GL_STENCIL_BUFFER_BIT)
beginFrame c (fromIntegral width) (fromIntegral height) pxRatio
renderDemo c demoData mx my width height t
endFrame c
swapBuffers w
pollEvents
renderDemo :: Context -> DemoData -> Double -> Double -> Int -> Int -> Double -> IO ()
renderDemo c demoData mx my w h t =
do drawEyes c (fromIntegral w - 250) 50 150 100 (realToFrac mx) (realToFrac my) (realToFrac t)
drawParagraph c (fromIntegral w - 450) 50 150 100 (realToFrac mx) (realToFrac my)
drawGraph c 0 (fromIntegral h/2) (fromIntegral w) (fromIntegral h/2) (realToFrac t)
drawColorwheel c (fromIntegral w - 300) (fromIntegral h - 300) 250 250 (realToFrac t)
drawLines c 120 (fromIntegral h - 50) 600 50 (realToFrac t)
drawWidths c 10 50 30
drawCaps c 10 300 30
drawScissor c 50 (fromIntegral h-80) (realToFrac t)
save c
let popy = 95 + 24
drawThumbnails c 365 popy 160 300 (images demoData) (realToFrac t)
restore c
drawThumbnails :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> V.Vector Image -> CFloat -> IO ()
drawThumbnails vg x y w h images t =
do let cornerRadius = 3
thumb = 60
arry = 30.5
nimages = V.length images
stackh = (fromIntegral nimages/2)*(thumb+10)+10
u = (1+cos (t*0.5))*0.5
u2 = (1-cos (t*0.2))*0.5
dv = 1/(fromIntegral nimages - 1)
save vg
shadowPaint <- boxGradient vg x (y+4) w h (cornerRadius*2) 20 (rgba 0 0 0 128) (rgba 0 0 0 0)
beginPath vg
rect vg (x-10) (y-10) (w+20) (h+30)
roundedRect vg x y w h cornerRadius
pathWinding vg (fromIntegral $ fromEnum Hole)
fillPaint vg shadowPaint
fill vg
beginPath vg
roundedRect vg x y w h cornerRadius
moveTo vg (x-10) (y+arry)
lineTo vg (x+1) (y+arry-11)
lineTo vg (x+1) (y+arry+11)
fillColor vg (rgba 200 200 200 255)
fill vg
save vg
scissor vg x y w h
translate vg 0 (-(stackh-h)*u)
flip V.imapM_ images $ \i image -> do
let tx = x + 10 + fromIntegral (i `mod` 2) * (thumb + 10)
ty = y + 10 + fromIntegral (i `div` 2) * (thumb + 10)
v = fromIntegral i * dv
a = clamp ((u2-v)/dv) 0 1
drawImage iw ih ix iy = do
imgPaint <- imagePattern vg (tx+ix) (ty+iy) iw ih (0/180*pi) image a
beginPath vg
roundedRect vg tx ty thumb thumb 5
fillPaint vg imgPaint
fill vg
(imgw,imgh) <- imageSize vg image
when (a < 1) $ drawSpinner vg (tx + thumb/2) (ty+thumb/2) (thumb*0.25) t
if imgw < imgh
then
let iw = thumb
ih = iw*fromIntegral imgh/fromIntegral imgw
ix = 0
iy = -(ih-thumb)*0.5
in drawImage iw ih ix iy
else
let ih = thumb
iw = ih * fromIntegral imgw/ fromIntegral imgh
ix = -(iw-thumb)*0.5
iy = 0
in drawImage iw ih ix iy
shadowPaint <- boxGradient vg (tx-1) ty (thumb+2) (thumb+2) 5 3 (rgba 0 0 0 128) (rgba 0 0 0 0)
beginPath vg
rect vg (tx-5) (ty-5) (thumb+10) (thumb+10)
roundedRect vg tx ty thumb thumb 6
pathWinding vg (fromIntegral $ fromEnum Hole)
fillPaint vg shadowPaint
fill vg
beginPath vg
roundedRect vg (tx+0.5) (ty+0.5) (thumb-1) (thumb-1) (4-0.5)
strokeWidth vg 1
strokeColor vg (rgba 255 255 255 192)
stroke vg
restore vg
restore vg
drawSpinner :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawSpinner vg cx cy r t =
do let a0 = 0+t*6
a1 = pi + t*6
r0 = r
r1 = r*0.75
save vg
beginPath vg
arc vg cx cy r0 a0 a1 CW
arc vg cx cy r1 a1 a0 CCW
closePath vg
let ax = cx+cos a0 * (r0+r1)*0.5
ay = cy+sin a0 * (r0+r1)*0.5
bx = cx+cos a1 * (r0+r1)*0.5
by = cy+sin a1 * (r0+r1)*0.5
paint <- linearGradient vg ax ay bx by (rgba 0 0 0 0) (rgba 0 0 0 128)
fillPaint vg paint
fill vg
restore vg
drawEyes :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawEyes c@(Context c') x y w h mx my t = do
bg <- linearGradient c x (y+h*0.5) (x+w*0.1) (y+h) (rgba 0 0 0 32) (rgba 0 0 0 16)
beginPath c
ellipse c (lx+3) (ly+16) ex ey
ellipse c (rx+3) (ry+16) ex ey
fillPaint c bg
fill c
bg <- linearGradient c x (y+h*0.25) (x+w*0.1) (y+h) (rgba 220 220 220 255) (rgba 128 128 128 255)
beginPath c
ellipse c lx ly ex ey
ellipse c rx ry ex ey
fillPaint c bg
fill c
let dx' = (mx - rx) / (ex * 10)
dy' = (my - ry) / (ey * 10)
d = sqrt (dx'*dx'+dy'*dy')
dx'' = if d > 1 then dx'/d else dx'
dy'' = if d > 1 then dy'/d else dy'
dx = dx'' * ex * 0.4
dy = dy'' * ey * 0.5
beginPath c
ellipse c (lx+dx) (ly+dy+ey*0.25*(1-blink)) br (br*blink)
fillColor c (rgba 32 32 32 255)
fill c
let dx'' = (mx - rx) / (ex * 10)
dy'' = (my - ry) / (ey * 10)
d = sqrt (dx'' * dx'' + dy'' * dy'')
dx' = if d > 1 then dx'' / d else dx''
dy' = if d > 1 then dy'' / d else dy''
dx = dx' * ex * 0.4
dy = dy' * ey * 0.5
beginPath c
ellipse c (rx+dx) (ry+dy+ey*0.25*(1-blink)) br (br*blink)
fillColor c (rgba 32 32 32 255)
fill c
gloss <- radialGradient c (lx-ex*0.25) (ly-ey*0.5) (ex*0.1) (ex*0.75) (rgba 255 255 255 128) (rgba 255 255 255 0)
beginPath c
ellipse c lx ly ex ey
fillPaint c gloss
fill c
gloss <- radialGradient c (rx-ex*0.25) (ry-ey*0.5) (ex*0.1) (ex*0.75) (rgba 255 255 255 128) (rgba 255 255 255 0)
beginPath c
ellipse c rx ry ex ey
fillPaint c gloss
fill c
where ex = w * 0.23
ey = h * 0.5
lx = x + ex
ly = y + ey
rx = x + w - ex
ry = y + ey
br = 0.5 * min ex ey
blink = 1 - ((sin (t*0.5))**200)*0.8
drawParagraph :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawParagraph c x y w h mx my =
do save c
fontSize c 18
fontFace c "sans"
textAlign c (S.fromList [AlignLeft,AlignTop])
(_,_,lineh) <- textMetrics c
gutter <- newIORef Nothing
yEnd <- newIORef y
NVG.textBreakLines c text w 3 $ \row i -> do
let y' = y + fromIntegral i * lineh
hit = mx > x && mx < (x+w) && my >= y' && my < (y' + lineh)
writeIORef yEnd y'
beginPath c
fillColor c (rgba 255 255 255 (if hit then 64 else 16))
rect c x y' (width row) lineh
fill c
fillColor c (rgba 255 255 255 255)
Internal.text c x y' (start row) (end row)
when hit $ do
let caretxInit = if mx < x+ (width row) / 2 then x else x + width row
ps = x
glyphs <- NVG.textGlyphPositions c x y (start row) (end row) 100
let leftBorders = V.map glyphX glyphs
rightBorders = V.snoc (V.drop 1 leftBorders) (x + width row)
rightPoints = V.zipWith (\x y -> 0.3*x+0.7*y) leftBorders rightBorders
leftPoints = V.cons x (V.take (V.length glyphs - 1) rightPoints)
caretx = maybe caretxInit (glyphX . (glyphs V.!)) $ V.findIndex (\(px,gx) -> mx >= px && mx < gx) $ V.zip leftPoints rightPoints
beginPath c
fillColor c (rgba 255 192 0 255)
rect c caretx y' 1 lineh
fill c
-- realized too late that I probably should have used a fold
writeIORef gutter (Just (i+1,x-10,y'+lineh/2))
gutter' <- readIORef gutter
forM_ gutter' $ \(gutter,gx,gy) -> do
let txt = T.pack $ show gutter
fontSize c 13
textAlign c (S.fromList [AlignRight,AlignMiddle])
(Bounds (V4 b0 b1 b2 b3)) <- textBounds c gx gy txt
beginPath c
fillColor c (rgba 255 192 0 255)
roundedRect c (b0-4) (b1-2) ((b2-b0)+8) ((b3-b1)+4) (((b3-b1)+4)/2-1)
fill c
fillColor c (rgba 32 32 32 255)
NVG.text c gx gy txt
y' <- (\x -> x+20+lineh) <$> readIORef yEnd
fontSize c 13
textAlign c (S.fromList [AlignLeft, AlignTop])
textLineHeight c 1.2
(Bounds (V4 b0 b1 b2 b3)) <- textBoxBounds c x y' 150 helpText
let gx = abs $ (mx - (b0+b2)*0.5) / (b0 - b2)
gy = abs $ (my - (b1+b3)*0.5) / (b1 - b3)
a = (\x -> clamp x 0 1) $ max gx gy - 0.5
globalAlpha c a
beginPath c
fillColor c (rgba 220 220 220 255)
roundedRect c (b0-2) (b1-2) ((b2-b0)+4) ((b3-b1)+4) 3
let px = (b2+b0)/2
moveTo c px (b1-10)
lineTo c (px+7) (b1+1)
lineTo c (px-7) (b1+1)
fill c
fillColor c (rgba 0 0 0 220)
textBox c x y' 150 helpText
restore c
where text = "This is longer chunk of text.\n \n Would have used lorem ipsum but she was busy jumping over the lazy dog with the fox and all the men who came to the aid of the party."
helpText = "Hover your mouse over the text to see calculated caret position."
drawGraph :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawGraph c x y w h t =
do bg <- linearGradient c x y x (y+h) (rgba 0 16 192 0) (rgba 0 160 192 64)
beginPath c
moveTo c (sx V.! 0) (sy V.! 0)
forM_ [1..5] $ \i ->
bezierTo c (sx V.! (i-1) + dx*0.5) (sy V.! (i-1)) (sx V.! i - dx*0.5) (sy V.! i) (sx V.! i) (sy V.! i)
lineTo c (x+w) (y+h)
lineTo c x (y+h)
fillPaint c bg
fill c
beginPath c
moveTo c (sx V.! 0) (sy V.! 0 + 2)
forM_ [1..5] $ \i ->
bezierTo c (sx V.! (i-1)+dx*0.5) (sy V.! (i-1)+2) (sx V.! i - dx*0.5) (sy V.! i + 2) (sx V.! i) (sy V.! i + 2)
strokeColor c (rgba 0 0 0 32)
strokeWidth c 3
stroke c
beginPath c
moveTo c (sx V.! 0) (sy V.! 0)
forM_ [1..5] $ \i ->
bezierTo c (sx V.! (i-1)+dx*0.5) (sy V.! (i-1)) (sx V.! i - dx*0.5) (sy V.! i) (sx V.! i) (sy V.! i)
strokeColor c (rgba 0 160 192 255)
strokeWidth c 3
stroke c
V.forM_ (V.zip sx sy) $ \(x,y) ->
do bg <- radialGradient c x (y+2) 3 8 (rgba 0 0 0 32) (rgba 0 0 0 0)
beginPath c
rect c (x-10) (y-10+2) 20 20
fillPaint c bg
fill c
beginPath c
V.forM_ (V.zip sx sy) $ \(x,y) -> circle c x y 4
fillColor c (rgba 0 160 192 255)
fill c
beginPath c
V.forM_ (V.zip sx sy) $ \(x,y) -> circle c x y 2
fillColor c (rgba 220 220 220 255)
fill c
strokeWidth c 1
where samples :: V.Vector CFloat
samples =
V.fromList
[(1 + sin (t * 1.2345 + cos (t * 0.33457) * 0.44)) * 0.5
,(1 + sin (t * 0.68363 + cos (t * 1.3) * 1.55)) * 0.5
,(1 + sin (t * 1.1642 + cos (t * 0.33457) * 1.24)) * 0.5
,(1 + sin (t * 0.56345 + cos (t * 1.63) * 0.14)) * 0.5
,(1 + sin (t * 1.6245 + cos (t * 0.254) * 0.3)) * 0.5
,(1 + sin (t * 0.345 + cos (t * 0.03) * 0.6)) * 0.5]
dx = w / 5
sx :: V.Vector CFloat
sx =
V.generate 6
(\i -> x + fromIntegral i * dx)
sy :: V.Vector CFloat
sy = V.map (\s -> y + h * s * 0.8) samples
drawColorwheel :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawColorwheel c x y w h t =
do save c
forM_ [0..5] $ \i ->
do let a0 = i / 6 * pi * 2 - aeps
a1 = (i+1)/6*pi*2+aeps
beginPath c
arc c cx cy r0 a0 a1 CW
arc c cx cy r1 a1 a0 CCW
closePath c
let ax = cx + cos a0 * (r0+r1)*0.5
ay = cy+sin a0 * (r0+r1)*0.5
bx = cx + cos a1 * (r0+r1) * 0.5
by = cy + sin a1 * (r0 + r1) * 0.5
paint <- linearGradient c ax ay bx by (hsla (a0/(2*pi)) 1 0.55 255) (hsla (a1/(2*pi)) 1 0.55 255)
fillPaint c paint
fill c
beginPath c
circle c cx cy (r0-0.5)
circle c cx cy (r1+0.5)
strokeColor c (rgba 0 0 0 64)
strokeWidth c 1
stroke c
save c
translate c cx cy
rotate c (hue*pi*2)
strokeWidth c 2
beginPath c
rect c (r0-1) (-3) (r1-r0+2) 6
strokeColor c (rgba 255 255 255 192)
stroke c
paint <- boxGradient c (r0-3) (-5) (r1-r0+6) 10 2 4 (rgba 0 0 0 128) (rgba 0 0 0 0)
beginPath c
rect c (r0-2-10) (-4-10) (r1-r0+4+20) (8+20)
rect c (r0-2) (-4) (r1-r0+4) 8
pathWinding c (fromIntegral$fromEnum Hole)
fillPaint c paint
fill c
let r = r0 - 6
ax = cos (120/180*pi) * r
ay = sin(120/180*pi) * r
bx = cos (-120/180*pi) * r
by = sin(-120/180*pi) * r
beginPath c
moveTo c r 0
lineTo c ax ay
lineTo c bx by
closePath c
paint <- linearGradient c r 0 ax ay (hsla hue 1 0.5 255) (rgba 255 255 255 255)
fillPaint c paint
fill c
strokeColor c (rgba 0 0 0 64)
stroke c
let ax = cos (120/180*pi)*r*0.3
ay = sin(120/180*pi)*r*0.4
strokeWidth c 2
beginPath c
circle c ax ay 5
strokeColor c (rgba 255 255 255 192)
stroke c
paint <- radialGradient c ax ay 7 9 (rgba 0 0 0 64) (rgba 0 0 0 0)
beginPath c
rect c (ax-20) (ay-20) 40 40
circle c ax ay 7
pathWinding c (fromIntegral$fromEnum Hole)
fillPaint c paint
fill c
restore c
restore c
where hue = sin (t * 0.12)
cx = x + w*0.5
cy = y+h*0.5
r1 = min w h * 0.5 - 5
r0 = r1 - 20
aeps = 0.5 / r1
drawLines :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawLines c x y w h t =
do save c
forM_ [0..2] $ \i -> forM_ [0..2] $ \j ->
do let fx = x +s*0.5+(fromIntegral i*3+fromIntegral j)/9*w+pad
fy = y-s*0.5+pad
lineCap c (caps V.! i)
lineJoin c (joins V.! j)
strokeWidth c (s*0.3)
strokeColor c (rgba 0 0 0 160)
beginPath c
moveTo c (fx + pts V.! 0) (fy + pts V.! 1)
moveTo c (fx + pts V.! 2) (fy + pts V.! 3)
moveTo c (fx + pts V.! 4) (fy + pts V.! 5)
moveTo c (fx + pts V.! 6) (fy + pts V.! 7)
stroke c
lineCap c Butt
lineJoin c Bevel
strokeWidth c 1
strokeColor c (rgba 0 192 255 255)
beginPath c
moveTo c (fx + pts V.! 0) (fy + pts V.! 1)
moveTo c (fx + pts V.! 2) (fy + pts V.! 3)
moveTo c (fx + pts V.! 4) (fy + pts V.! 5)
moveTo c (fx + pts V.! 6) (fy + pts V.! 7)
stroke c
restore c
where pad = 0.5
s = w / 9 - pad * 2
joins = V.fromList [Miter,Round,Bevel]
caps = V.fromList [Butt,Round,Square]
pts =
V.fromList
[-s * 0.25 + cos (t * 0.3) * s * 0.5
,sin (t * 0.3) * s * 0.5
,-s * 0.25
,0
,s * 0.25
,0
,s * 0.25 + cos (-t * 0.3) * s * 0.5
,sin (-t * 0.3) * s * 0.5]
drawWidths :: Context -> CFloat -> CFloat -> CFloat -> IO ()
drawWidths c x y width =
do save c
strokeColor c (rgba 0 0 0 255)
forM_ [0..19] $ \i ->
do let w = (i+0.5)*0.1
y' = y + (10*i)
strokeWidth c w
beginPath c
moveTo c x y'
lineTo c (x+width) (y'+width*0.3)
stroke c
restore c
data DemoData =
DemoData {fontNormal :: Font
,fontBold :: Font
,fontIcons :: Font
,images :: V.Vector Image}
loadDemoData :: Context -> MaybeT IO DemoData
loadDemoData c = do icons <- MaybeT $ createFont c "icons" (FileName "nanovg/example/entypo.ttf")
normal <- MaybeT $ createFont c "sans" (FileName "nanovg/example/Roboto-Regular.ttf")
bold <- MaybeT $ createFont c "sans-bold" (FileName "nanovg/example/Roboto-Bold.ttf")
images <- loadImages
pure (DemoData icons normal bold images)
where loadImages :: MaybeT IO (V.Vector Image)
loadImages =
V.generateM 12 $
\i ->
do let file = FileName $
"nanovg/example/images/image" <> T.pack (show (i + 1)) <> ".jpg"
MaybeT $ createImage c file 0
drawCaps :: Context -> CFloat -> CFloat -> CFloat -> IO ()
drawCaps c x y width =
do save c
beginPath c
rect c (x-lineWidth/2) y (width+lineWidth) 40
fillColor c (rgba 255 255 255 32)
fill c
beginPath c
rect c x y width 40
fillColor c (rgba 255 255 255 32)
fill c
strokeWidth c lineWidth
forM_ (zip [0..] [Butt,Round,Square]) $ \(i,cap) ->
do lineCap c cap
strokeColor c (rgba 0 0 0 255)
beginPath c
moveTo c x (y+i*10+5)
lineTo c (x+width) (y+i*10+5)
stroke c
restore c
where lineWidth = 8
drawScissor :: Context -> CFloat -> CFloat -> CFloat -> IO ()
drawScissor c x y t =
do save c
translate c x y
rotate c (degToRad 5)
beginPath c
rect c (-20) (-20) 60 40
fillColor c (rgba 255 0 0 255)
fill c
scissor c (-20) (-20) 60 40
translate c 40 0
rotate c t
save c
resetScissor c
beginPath c
rect c (-20) (-10) 60 30
fillColor c (rgba 255 128 0 64)
fill c
restore c
intersectScissor c (-20) (-10) 60 30
beginPath c
rect c (-20) (-10) 60 30
fillColor c (rgba 255 128 0 255)
fill c
restore c
clamp :: Ord a => a -> a -> a -> a
clamp a' low up
| a' < low = low
| a' > up = up
| otherwise = a'