{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.MicroPrint.DrawMonad-- Copyright : (c) Stephen Tetley 2010-- License : BSD3---- Maintainer : stephen.tetley@gmail.com-- Stability : unstable-- Portability : GHC---- MicroPrints drawing monad - drawing here is analogous to a -- /teletype/ drawing characters, spaces and linebreaks one at a -- time.----------------------------------------------------------------------------------moduleWumpus.MicroPrint.DrawMonad(MicroPrint,runMicroPrint,execMicroPrint,Tile(..),Height,linebreak,setRGB,char,space)whereimportWumpus.CoreimportWumpus.Core.Colour(black)importWumpus.Basic.Utils.HListimportControl.MonaddataTile=LineBreak|SpaceInt|WordRGBiInt-- Interim version without colour annotation...dataTileState=Start|S0Int|W0InttypeText=HTiletypeTrace=TexttypeHeight=InttypeState=(TileState,RGBi,Height)-- | Build a /microprint/ within a monad...---- Drawings are made in a /teletype/ fashion emitting a character,-- space or line-break at each step.--newtypeMicroPrinta=MicroPrint{getMicroPrint::Trace->State->(a,Trace,State)}instanceFunctorMicroPrintwherefmapfm=MicroPrint$\ws->let(a,w',s')=getMicroPrintmwsin(fa,w',s')instanceMonadMicroPrintwherereturna=MicroPrint$\ws->(a,w,s)m>>=k=MicroPrint$\ws->let(a,w',s')=getMicroPrintmwsin(getMicroPrint.k)aw's'runMicroPrint::MicroPrinta->(a,[Tile],Height)runMicroPrintm=post$getMicroPrintmemptyH(Start,black,1)wherepost(a,f,(W0n,rgb,h))=(a,toListH$f`snocH`(Wordrgbn),h)post(a,f,(_,_,h))=(a,f[],h)execMicroPrint::MicroPrinta->([Tile],Height)execMicroPrint=post.runMicroPrintwherepost(_,xs,h)=(xs,h)enqueueTile::MicroPrint()enqueueTile=MicroPrint$\w(opt,rgb,h)->lettileF=steprgboptin((),tileFw,(Start,rgb,h))wherestep_Start=idstep_(S0n)=(\f->f`snocH`(Spacen))steprgb(W0n)=(\f->f`snocH`(Wordrgbn))-- | Emit a linebreak in the output.--linebreak::MicroPrint()linebreak=enqueueTile>>nextwherenext=MicroPrint$\w(opt,rgb,h)->((),w`snocH`LineBreak,(opt,rgb,h+1))-- | Change the current drawing colour.---- Note - it is permissible to change colour mid-word, but this -- is the same as having a no-space break.--setRGB::RGBi->MicroPrint()setRGBrgb=enqueueTile>>nextwhere-- tip will always be Start here...next=MicroPrint$\w(tip,_,h)->((),w,(tip,rgb,h))-- | Draw a character - note in the microprint, characters will -- be concatenated together to make a word.--char::MicroPrint()char=MicroPrint$\w(tip,rgb,h)->let(f,tip')=addChartipin((),fw,(tip',rgb,h))whereaddCharStart=(id,W01)addChar(W0n)=(id,W0$n+1)addChar(S0n)=(\f->f`snocH`(Spacen),W01)-- | Draw a space.--space::MicroPrint()space=MicroPrint$\w(tip,rgb,h)->let(f,tip')=addSpacetiprgbin((),fw,(tip',rgb,h))whereaddSpaceStart_=(id,S01)addSpace(W0n)rgb=(\f->f`snocH`(Wordrgbn),S01)addSpace(S0n)_=(id,S0$n+1)