{-# LANGUAGE CPP #-}---------------------------------------------------------------- | -- Module : Graphics.DrawingCombinators-- Copyright : (c) Luke Palmer 2008-2010-- License : BSD3---- Maintainer : Luke Palmer <lrpalmer@gmail.com>-- Stability : experimental-- Portability : tested on GHC only---- Drawing combinators as a functional interface to 2D graphics using OpenGL.---- This module is intended to be imported @qualified@, as in:---- > import qualified Graphics.DrawingCombinators as Draw---- Whenever possible, a /denotational semantics/ for operations in this library-- is given. Read @[[x]]@ as \"the meaning of @x@\".---- Intuitively, an 'Image' @a@ is an infinite plane of pairs of colors /and/-- @a@\'s. The colors are what are drawn on the screen when you 'render', and-- the @a@\'s are what you can recover from coordinates using 'sample'. The-- latter allows you to tell, for example, what a user clicked on.---- The following discussion is about the associated data. If you are only-- interested in drawing, rather than mapping from coordinates to values, you-- can ignore the following and just use 'mappend' and 'mconcat' to overlay images.---- Wrangling the @a@\'s -- the associated data with each \"pixel\" -- is done-- using the 'Functor', 'Applicative', and 'Monoid' instances. ---- The primitive @Image@s such as 'circle' and 'text' all return @Image Any@-- objects. 'Any' is just a wrapper around 'Bool', with @(||)@ as its monoid-- operator. So e.g. the points inside the circle will have the value @Any-- True@, and those outside will have the value @Any False@. Returning @Any@-- instead of plain @Bool@ allows you to use @Image@s as a monoid, e.g.-- 'mappend' to overlay two images. But if you are doing anything with-- sampling, you probably want to map this to something. Here is a drawing-- with two circles that reports which one was hit:---- > twoCircles :: Image String-- > twoCircles = liftA2 test (translate (-1,0) %% circle) (translate (1,0) %% circle)-- > where -- > test (Any False) (Any False) = "Miss!"-- > test (Any False) (Any True) = "Hit Right!"-- > test (Any True) (Any False) = "Hit Left!"-- > test (Any True) (Any True) = "Hit Both??!"---- The last case would only be possible if the circles were overlapping.--------------------------------------------------------------moduleGraphics.DrawingCombinators(moduleGraphics.DrawingCombinators.Affine-- * Basic types,Image,render,clearRender-- * Selection,sample-- * Geometry,point,line,regularPoly,circle,convexPoly,(%%),bezierCurve-- * Colors,Color(..),modulate,tint-- * Sprites (images from files),Sprite,openSprite,sprite-- * Text,Font,openFont,text,textWidth,Monoid(..),Any(..))whereimportGraphics.DrawingCombinators.AffineimportControl.Applicative(Applicative(..),liftA2,(*>),(<$>))importData.Maybe(fromMaybe)importControl.Monad(forM_,unless)importData.Monoid(Monoid(..),Any(..))importqualifiedData.SetasSetimportqualifiedGraphics.Rendering.OpenGL.GLasGLimportqualifiedGraphics.Rendering.OpenGL.GLUasGLUimportqualifiedCodec.Image.STBasImageimportqualifiedData.Bitmap.OpenGLasBitmapimportSystem.IO.Unsafe(unsafePerformIO)-- for pure textWidth#ifdef LAME_FONTSimportqualifiedGraphics.UI.GLUTasGLUT#elseimportqualifiedGraphics.Rendering.FTGLasFTGLimportSystem.Mem.Weak(addFinalizer)#endiftypeRenderer=Affine->Color->IO()typePickera=Affine->GL.GLuint->IO(GL.GLuint,Set.SetGL.GLuint->a)-- | The type of images.---- > [[Image a]] = R2 -> (Color, a)---- The semantics of the instances are all consistent with /type class morphism/.-- I.e. Functor, Applicative, and Monoid act point-wise, using the 'Color' monoid-- described below.dataImagea=Image{dRender::Renderer,dPick::Pickera}instanceFunctorImagewherefmapfd=Image{dRender=dRenderd,dPick=(fmap.fmap.fmap.fmap.fmap)f(dPickd)}instanceApplicativeImagewherepurex=Image{dRender=(pure.pure.pure)(),dPick=\_z->pure(z,constx)}df<*>dx=Image{-- reversed so that things that come first go on topdRender=(liftA2.liftA2)(*>)(dRenderdx)(dRenderdf),dPick=\trz->do(z',m')<-dPickdxtrz(z'',m)<-dPickdftrz'return(z'',m<*>m')}instance(Monoidm)=>Monoid(Imagem)wheremempty=purememptymappend=liftA2mappend-- |Draw an Image on the screen in the current OpenGL coordinate-- system (which, in absense of information, is (-1,-1) in the-- lower left and (1,1) in the upper right).render::Imagea->IO()renderd=GL.preservingAttrib[GL.AllServerAttributes]$doGL.textureGL.Texture2DGL.$=GL.EnabledGL.blendGL.$=GL.EnabledGL.blendFuncGL.$=(GL.SrcAlpha,GL.OneMinusSrcAlpha)-- For now we assume the user wants antialiasing; the general solution is not clear - maybe let the-- user do the opengl setup stuff himself? otherwise need to wrap all of the possible things GL lets-- you set.GL.polygonSmoothGL.$=GL.EnabledGL.lineSmoothGL.$=GL.EnabledGL.lineWidthGL.$=1.5GL.hintGL.LineSmoothGL.$=GL.DontCaredRenderdidentitymempty-- |Like 'render', but clears the screen first. This is so-- you can use this module and pretend that OpenGL doesn't-- exist at all.clearRender::Imagea->IO()clearRenderd=doGL.clear[GL.ColorBuffer]renderd-- | Given a bounding box, lower left and upper right in the default coordinate-- system (-1,-1) to (1,1), return the topmost drawing's value (with respect to-- @`over`@) intersecting that bounding box.selectRegion::R2->R2->Imagea->IOaselectRegionllurdrawing=do(lookup',recs)<-GL.getHitRecords64$-- XXX hard coded crapGL.preservingMatrix$doGL.loadIdentityGLU.ortho2D(fstll)(fstur)(sndll)(sndur)(_,lookup')<-dPickdrawingidentity0returnlookup'letnameList=concatMap(\(GL.HitRecord__ns)->ns)(fromMaybe[]recs)letnameSet=Set.fromList$map(\(GL.Namen)->n)nameListreturn$lookup'nameSet-- | Sample the value of the image at a point. ---- > [[sample i p]] = snd ([[i]] p)---- Even though this ought to be a pure function, it is /not/ safe to-- @unsafePerformIO@ it, because it uses OpenGL state.sample::Imagea->R2->IOasampleim(px,py)=selectRegion(px-e,py-e)(px+e,py+e)imwheree=1/1024{----------------
Geometry
-----------------}toVertex::Affine->R2->GL.Vertex2GL.GLdoubletoVertextrp=let(x,y)=tr`apply`pinGL.Vertex2xytoVertex3::R->Affine->R2->GL.Vertex3GL.GLdoubletoVertex3ztrp=let(x,y)=tr`apply`pinGL.Vertex3xyzinSet::(Orda)=>a->Set.Seta->AnyinSetxs=Any(x`Set.member`s)picker::Renderer->PickerAnypickerrtrz=z`seq`doGL.withName(GL.Namez)(rtrmempty)return(z+1,inSetz)rendererImage::Renderer->ImageAnyrendererImagef=Imagef(pickerf)-- | A single \"pixel\" at the specified point.---- > [[point p]] r | [[r]] == [[p]] = (one, Any True) -- > | otherwise = (zero, Any False)point::R2->ImageAnypointp=rendererImage$\tr_->doGL.renderPrimitiveGL.Points.GL.vertex$toVertextrp-- | A line connecting the two given points.line::R2->R2->ImageAnylinesrcdest=rendererImage$\tr_->doGL.renderPrimitiveGL.Lines$doGL.vertex$toVertextrsrcGL.vertex$toVertextrdest-- | A regular polygon centered at the origin with n sides.regularPoly::Integrala=>a->ImageAnyregularPolyn=rendererImage$\tr_->doletscaler=2*pi/fromIntegralnGL.renderPrimitiveGL.TriangleFan$doGL.vertex$toVertextr(0,0)forM_[0..n]$\s->dolettheta=scaler*fromIntegralsGL.vertex$toVertextr(costheta,sintheta)-- | An (imperfect) unit circle centered at the origin. Implemented as:---- > circle = regularPoly 24circle::ImageAnycircle=regularPoly(24::Int)-- | A convex polygon given by the list of points.convexPoly::[R2]->ImageAnyconvexPolypoints=rendererImage$\tr_->doGL.renderPrimitiveGL.Polygon$mapM_(GL.vertex.toVertextr)points-- | A Bezier curve given a list of control points. It is a curve-- that begins at the first point in the list, ends at the last one,-- and smoothly interpolates between the rest. It is the empty-- image ('mempty') if zero or one points are given.bezierCurve::[R2]->ImageAnybezierCurvecontrolPoints=rendererImage$\tr_->do-- todo check at least 4 points?letps=map(toVertex30tr)controlPointsm<-GL.newMap1(0,1)ps::IO(GL.GLmap1(GL.Vertex3)R)GL.map1GL.$=JustmGL.mapGrid1GL.$=(100,(0::R,1))GL.evalMesh1GL.Line(1,100){-----------------
Transformations
------------------}infixr1%%-- | Transform an image by an 'Affine' transformation.---- > [[tr % im]] = [[im]] . inverse [[tr]](%%)::Affine->Imagea->Imageatr'%%d=Imagerender'pickwhererender'trcol=dRenderd(tr`compose`tr')colpicktrz=dPickd(tr`compose`tr')z{------------
Colors
-------------}-- | Color is defined in the usual computer graphics sense:-- a 4 vector containing red, green, blue, and alpha.---- The Monoid instance is given by alpha composition, described-- at @http:\/\/lukepalmer.wordpress.com\/2010\/02\/05\/associative-alpha-blending\/@---- In the semantcs the values @zero@ and @one@ are used, which are defined as:---- > zero = Color 0 0 0 0-- > one = Color 1 1 1 1dataColor=Color!R!R!R!Rderiving(Eq,Show)instanceMonoidColorwheremempty=Color0000mappend(Colorrgba)(Colorr'g'b'a')=Color(irr')(igg')(ibb')γwhereγ=a+a'-a*a'i|γ==0=\__->0-- imples a = a' = 0|otherwise=\xy->(a*x+(1-a)*a'*y)/γ-- | Modulate two colors by each other.---- > modulate (Color r g b a) (Color r' g' b' a') -- > = Color (r*r') (g*g') (b*b') (a*a')modulate::Color->Color->Colormodulate(Colorrgba)(Colorr'g'b'a')=Color(r*r')(g*g')(b*b')(a*a')-- | Tint an image by a color; i.e. modulate the colors of an image by -- a color.---- > [[tint c im]] = first (modulate c) . [[im]]-- > where first f (x,y) = (f x, y)tint::Color->Imagea->Imageatintcd=Imagerender'(dPickd)whererender'trcol=doletoldColor=colnewColor=modulateccolsetColornewColorresult<-dRenderdtrnewColorsetColoroldColorreturnresultsetColor(Colorrgba)=GL.color$GL.Color4rgba{-------------------------
Sprites (bitmap images)
-------------------------}-- | A Sprite represents a finite bitmap image.---- > [[Sprite]] = [-1,1]^2 -> ColordataSprite=Sprite{spriteObject::GL.TextureObject}-- | Load an image from a file and create a sprite out of it.openSprite::FilePath->IOSpriteopenSpritepath=doe<-Image.loadImagepathcaseeofLefterr->failerrRightbmp->Sprite<$>Bitmap.makeSimpleBitmapTexturebmp-- | The image of a sprite at the origin.---- > [[sprite s]] p | p `elem` [-1,1]^2 = ([[s]] p, Any True) -- > | otherwise = (zero, Any False)sprite::Sprite->ImageAnyspritespr=rendererImage$\tr_->dooldtex<-GL.get(GL.textureBindingGL.Texture2D)GL.textureBindingGL.Texture2DGL.$=(Just$spriteObjectspr)GL.renderPrimitiveGL.Quads$dotexcoord00GL.vertex$toVertextr(-1,1)texcoord10GL.vertex$toVertextr(1,1)texcoord11GL.vertex$toVertextr(1,-1)texcoord01GL.vertex$toVertextr(-1,-1)GL.textureBindingGL.Texture2DGL.$=oldtexwheretexcoordxy=GL.texCoord$GL.TexCoord2(x::GL.GLdouble)(y::GL.GLdouble){---------
Text
---------}#ifdef LAME_FONTSdataFont=FontopenFont::String->IOFontopenFont_=doinited<-GLUT.getGLUT.initStateunlessinited$GLUT.initialize""[]>>return()returnFonttext::Font->String->ImageAnytextFontstr=rendererImage$\tr_->doGL.preservingMatrix$domultGLmatrixtrGL.scale(1/64::GL.GLdouble)(1/64)1GLUT.renderStringGLUT.RomanstrtextWidth::Font->String->RtextWidthFontstr=(1/64)*fromIntegral(unsafePerformIO(GLUT.stringWidthGLUT.Romanstr))#elsedataFont=Font{getFont::FTGL.Font}-- | Load a TTF font from a file.openFont::String->IOFontopenFontpath=dofont<-FTGL.createPolygonFontpathaddFinalizerfont(FTGL.destroyFontfont)return$Fontfont-- | The image representing some text rendered with a font. The baseline-- is at y=0, the text starts at x=0, and the height of a lowercase x is -- 1 unit.text::Font->String->ImageAnytextfontstr=rendererImage$\tr_->doGL.preservingMatrix$domultGLmatrixtrGL.scale(1/36::GL.GLdouble)(1/36)1_<-FTGL.setFontFaceSize(getFontfont)7272FTGL.renderFont(getFontfont)strFTGL.Allreturn()-- | @textWidth font str@ is the width of the text in @text font str@.textWidth::Font->String->RtextWidthfontstr=(/36).realToFrac.unsafePerformIO$do_<-FTGL.setFontFaceSize(getFontfont)7272FTGL.getFontAdvance(getFontfont)str#endif