lui 0.0.3 → 0.0.4
raw patch · 9 files changed
+187/−85 lines, 9 filesdep ~base
Dependency ranges changed: base
Files
- lui.cabal +2/−2
- src/Example.hs +32/−10
- src/Graphics/UI/LUI/Image.hs +66/−22
- src/Graphics/UI/LUI/Widget.hs +2/−3
- src/Graphics/UI/LUI/Widgets/Adapter.hs +34/−14
- src/Graphics/UI/LUI/Widgets/Box.hs +5/−1
- src/Graphics/UI/LUI/Widgets/Grid.hs +38/−22
- src/Graphics/UI/LUI/Widgets/KeysTable.hs +7/−9
- src/Graphics/UI/LUI/Widgets/Space.hs +1/−2
lui.cabal view
@@ -1,5 +1,5 @@ Name: lui-Version: 0.0.3+Version: 0.0.4 Cabal-Version: >= 1.2 Synopsis: Purely FunctionaL User Interface Category: graphics@@ -27,7 +27,7 @@ Library hs-Source-Dirs: src Extensions:- Build-Depends: base, haskell98, containers, mtl, SDL, haskgame, MaybeT+ Build-Depends: base >= 4 && < 5, haskell98, containers, mtl, SDL, haskgame, MaybeT Exposed-Modules: Graphics.UI.LUI.Accessor, Graphics.UI.LUI.Image, Graphics.UI.LUI.Run,
src/Example.hs view
@@ -1,22 +1,26 @@-{-# OPTIONS_GHC -Wall -O2- #-}+{-# OPTIONS_GHC -Wall -O2 #-} module Example(main) where import qualified Graphics.UI.LUI.Run as Run+import qualified Graphics.UI.LUI.Image as Image import qualified Graphics.UI.LUI.Widgets.TextEdit as TextEdit import qualified Graphics.UI.LUI.Widgets.TextView as TextView+import qualified Graphics.UI.LUI.Widgets.Scroll as Scroll import qualified Graphics.UI.LUI.Widgets.Grid as Grid import qualified Graphics.UI.LUI.Widgets.Box as Box import qualified Graphics.UI.LUI.Widgets.Space as Space import qualified Graphics.UI.LUI.Widgets.KeysTable as KeysTable+import qualified Graphics.UI.LUI.Widgets.Adapter as Adapter import Graphics.UI.LUI.Widget(Widget) import Graphics.UI.LUI.Accessor(Accessor, accessor, aMapValue, (^>), (^.)) import qualified Graphics.UI.HaskGame.Font as Font import qualified Graphics.UI.HaskGame as HaskGame+import Graphics.UI.HaskGame.Vector2(Vector2(..)) import Graphics.UI.HaskGame.Font(Font) import Graphics.UI.HaskGame.Color(Color(..))+import Graphics.UI.HaskGame.Rect(Rect(..)) import qualified Data.Map as Map import Data.Maybe(listToMaybe)@@ -39,6 +43,7 @@ vboxModel :: Box.DelegatedMutable , textEditModels :: Map.Map Grid.Cursor TextEdit.DelegatedMutable , gridModel :: Grid.DelegatedMutable+ , scrollModel :: Scroll.Mutable } data Fonts = Fonts@@ -49,6 +54,8 @@ -- TODO: Replace with TH auto-gen avboxModel :: Accessor Model Box.DelegatedMutable avboxModel = accessor vboxModel (\new x -> x{vboxModel=new})+scrollerModel :: Accessor Model Scroll.Mutable+scrollerModel = accessor scrollModel (\new x -> x{scrollModel=new}) atextEditModels :: Accessor Model (Map.Map Grid.Cursor TextEdit.DelegatedMutable) atextEditModels = accessor textEditModels (\new x -> x{textEditModels=new}) agridModel :: Accessor Model Grid.DelegatedMutable@@ -74,6 +81,7 @@ | x <- [0..1] , y <- [0..1]] , gridModel = Grid.delegatedMutable False (0, 0)+ , scrollModel = Scroll.Mutable $ Vector2 0 0 } @@ -93,15 +101,15 @@ textEditColor $ atextEditModels ^> aMapValue cursor -textView :: String -> Fonts -> Widget Model-textView text fonts =- TextView.new textViewColor (textViewFont fonts) text--grid, vbox, withKeysTable, proxy1, proxy2 :: Fonts -> Widget Model+textView :: String -> Font -> Widget Model+textView text font =+ TextView.new textViewColor font text gridSize :: Grid.Cursor gridSize = (2, 2) +grid, scrollBox, vbox, withKeysTable, proxy1, proxy2 :: Fonts -> Widget Model+ grid fonts = Grid.newDelegated gridSize items agridModel where@@ -109,14 +117,27 @@ [((x, y), Grid.Item (textEdit (x, y) fonts) (0.5, 1)) | x <- [0..1], y <- [0..1]] +scrollBox fonts = Scroll.new (Vector2 200 200) box scrollerModel+ where+ font = defaultFont fonts+ box = Box.new Box.Vertical items $ Box.noAcc 0+ items = [Box.Item (Adapter.adaptImage+ (Image.cropRect $ Rect i 0 (w-i-i) h) $+ textView text font) 0.5+ | i <- [0,20..250]+ , let text = "THIS IS A TRUNCATED VIEW: " ++ show i+ Vector2 w h = Image.textSize font text]+ vbox fonts = Box.newDelegated Box.Vertical items avboxModel where items = [Box.Item (grid fonts) 1 ,Box.Item (Space.newH 100) 0.5 ,Box.Item (proxy1 fonts) 0.5- ,Box.Item (textView "This is just a view" fonts) 0.5- ,Box.Item (proxy2 fonts) 0.5]+ ,Box.Item (proxy2 fonts) 0.5+ ,Box.Item (scrollBox fonts) 0.5+ ] + withKeysTable fonts = KeysTable.newBoxedWidget Box.Horizontal 50 (keysFont fonts) (descFont fonts) (vbox fonts) proxy1 fonts model =@@ -139,7 +160,8 @@ let cursor = model ^. agridModel ^. Grid.aDelegatedMutableCursor text = model ^. atextEditModels ^. aMapValue cursor ^. TextEdit.aDelegatedMutableText- in maybe (textView ("Invalid cursor position selected: " ++ text) fonts model)+ in maybe (textView ("Invalid cursor position selected: " ++ text)+ (textViewFont fonts) model) (\cur -> textEdit cur fonts model) $ readCursor text
src/Graphics/UI/LUI/Image.hs view
@@ -8,8 +8,10 @@ ,textSize ,rect ,move+ ,crop+ ,cropRect -- The implementational interface- ,Pos,render+ ,render ) where import qualified Graphics.UI.HaskGame as HaskGame@@ -19,45 +21,87 @@ import Graphics.UI.HaskGame.Vector2(Vector2(..)) import Graphics.UI.HaskGame.Color(Color) import Graphics.UI.HaskGame.Font(Font)-import Graphics.UI.HaskGame(Size)+import Graphics.UI.HaskGame.Rect(Rect(..)) import Data.Monoid(Monoid(..)) -type Pos = Vector2 Int+type BBox = Maybe Rect +-- bboxFromSize :: Vector2 Int -> BBox+-- bboxFromSize size = BBox $ Rect.makeRect (Vector2 0 0) size++-- onBBoxRect :: (Rect -> Rect) -> BBox -> BBox+-- onBBoxRect _ BBoxInf = BBoxInf+-- onBBoxRect f (BBox r) = BBox $ f r++-- unionBBox :: BBox -> BBox -> BBox+-- BBoxInf `unionBBox` _ = BBoxInf+-- _ `unionBBox` BBoxInf = BBoxInf+-- BBox r1 `unionBBox` BBox r2 = BBox $ r1 `unionRects` r2++intersectBBox :: BBox -> BBox -> BBox+Nothing `intersectBBox` b2 = b2+b1 `intersectBBox` Nothing = b1+(Just r1) `intersectBBox` (Just r2) = Just $ r1 `Rect.intersect` r2+ -- Image semantically represents an infinite map from pixel index to -- color.-newtype Image = Image- {- render :: Surface -> Pos -> IO ()- }+data Image = Image { imageDraw :: Surface -> Vector2 Int -> BBox -> IO () } +render :: Image -> Surface -> Vector2 Int -> IO ()+render image surface pos = imageDraw image surface pos Nothing+ instance Monoid Image where- mempty = Image $ const . const . return $ ()+ mempty = Image (const . const . const . return $ ()) Image xdraw `mappend` Image ydraw = Image draw where- draw surface pos = do- xdraw surface pos- ydraw surface pos+ draw surface pos bbox = xdraw surface pos bbox >>+ ydraw surface pos bbox --- Re-export this to match text below-textSize :: Font -> String -> Size+-- Re-export this to go along with text below+textSize :: Font -> String -> Vector2 Int textSize = Font.textSize +cropBlit :: Surface -> Vector2 Int -> Rect -> Surface -> IO ()+cropBlit dest destPos destCropRect src =+ HaskGame.blitPart dest finalTopLeft src srcRect+ where+ srcRect = Rect.make (finalTopLeft - requestedTopLeft) (Rect.getSize finalDest)+ finalTopLeft = Rect.getTopLeft finalDest+ finalDest = requestedDest `Rect.intersect` destCropRect+ requestedTopLeft = Rect.getTopLeft requestedDest+ requestedDest = Rect.make destPos srcSize+ srcSize = HaskGame.surfaceSize src+ text :: Color -> Font -> String -> Image text color font str = Image draw where- draw surface pos = do+ draw surface pos bbox = do textSurface <- Font.renderText font str color- HaskGame.blit surface pos textSurface+ maybe (HaskGame.blit surface pos)+ (cropBlit surface pos) bbox $ textSurface -rect :: Color -> Size -> Image+rect :: Color -> Vector2 Int -> Image rect color size = Image draw where- draw surface pos = do- HaskGame.fillRect surface (Rect.makeRect pos size) color+ draw surface pos bbox =+ let origRect = Rect.make pos size+ finalRect = Rect.trunc $ maybe origRect (origRect `Rect.intersect`) bbox+ in HaskGame.fillRect surface finalRect color -move :: Pos -> Image -> Image-move delta image = Image draw+move :: Vector2 Int -> Image -> Image+move delta (Image xdraw) = Image draw where- draw surface pos = do- render image surface (pos + delta)+ draw surface pos = xdraw surface (delta + pos)++cropRect :: Rect -> Image -> Image+cropRect r = move topLeft .+ crop size .+ move (-topLeft)+ where+ (topLeft, size) = Rect.toVectors r++crop :: Vector2 Int -> Image -> Image+crop cropSize (Image xdraw) = Image draw+ where+ draw surface pos bbox = xdraw surface pos $+ Just (Rect.make pos cropSize) `intersectBBox` bbox
src/Graphics/UI/LUI/Widget.hs view
@@ -16,7 +16,7 @@ import Graphics.UI.LUI.Image(Image) import Graphics.UI.LUI.Accessor(Accessor) -import Graphics.UI.HaskGame(Size)+import Graphics.UI.HaskGame.Vector2(Vector2) import qualified Graphics.UI.HaskGame.Key as Key import qualified Data.Map as Map@@ -34,11 +34,10 @@ } deriving (Eq, Ord, Show, Read) --- TODO: Consider moving the model argument outside of the record data WidgetFuncs model = WidgetFuncs { widgetImage :: DrawInfo -> Image- , widgetSize :: DrawInfo -> Size+ , widgetSize :: DrawInfo -> Vector2 Int , widgetGetKeymap :: Maybe (ActionHandlers model) }
src/Graphics/UI/LUI/Widgets/Adapter.hs view
@@ -1,27 +1,47 @@ {-# OPTIONS_GHC -Wall -O2 #-} -module Graphics.UI.LUI.Widgets.Adapter(adapt) where+module Graphics.UI.LUI.Widgets.Adapter+ (adaptAll+ ,adaptModel+ ,adaptImage+ ,adaptSize)+where import qualified Graphics.UI.LUI.Widget as Widget import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..))+import Graphics.UI.LUI.Image(Image) import Graphics.UI.LUI.Func(result) import Graphics.UI.LUI.Accessor(Accessor, write, (^.)) +import Graphics.UI.HaskGame.Vector2(Vector2)+ import qualified Data.Map as Map import Control.Arrow(second) -adapt :: Accessor whole part -> Widget part -> Widget whole-adapt acc widget model =- let widgetFuncs = widget (model ^. acc)- in- WidgetFuncs- {- widgetImage = widgetImage widgetFuncs- , widgetSize = widgetSize widgetFuncs- , widgetGetKeymap =- let keymap = widgetGetKeymap widgetFuncs- convertModel part = write acc part model- in (fmap . Map.map . second . result) convertModel $ keymap- }+type Endo a = a -> a++adaptAll :: Endo Image ->+ Endo (Vector2 Int) ->+ (Maybe (Widget.ActionHandlers part) ->+ Maybe (Widget.ActionHandlers whole)) ->+ WidgetFuncs part -> WidgetFuncs whole+adaptAll imageFunc sizeFunc keymapFunc widgetFuncs =+ WidgetFuncs+ {+ widgetImage = result imageFunc . widgetImage $ widgetFuncs+ , widgetSize = result sizeFunc . widgetSize $ widgetFuncs+ , widgetGetKeymap = keymapFunc . widgetGetKeymap $ widgetFuncs+ }++adaptModel :: Accessor whole part -> Widget part -> Widget whole+adaptModel acc widget model = adaptAll id id convertKeymap (widget (model ^. acc))+ where convertKeymap = fmap . Map.map . second . result $ convertModel+ convertModel part = write acc part model++adaptImage :: Endo Image -> Endo (Widget model)+adaptImage imageFunc widget model = adaptAll imageFunc id id $ widget model++adaptSize :: Endo (Vector2 Int) -> Endo (Widget model)+adaptSize sizeFunc widget model = adaptAll id sizeFunc id $ widget model
src/Graphics/UI/LUI/Widgets/Box.hs view
@@ -6,6 +6,7 @@ ,Item(..) ,Mutable(..) ,Cursor+ ,noAcc ,new ,aMutableCursor ,DelegatedMutable@@ -20,7 +21,7 @@ import qualified Graphics.UI.LUI.Widgets.FocusDelegator as FocusDelegator import Graphics.UI.LUI.Widget(Widget) import Graphics.UI.LUI.Tuple(swap)-import Graphics.UI.LUI.Accessor(Accessor, convertor, (^>))+import Graphics.UI.LUI.Accessor(Accessor, reader, convertor, (^>)) import Graphics.UI.HaskGame.Color(Color(..)) @@ -45,6 +46,9 @@ -- TODO: Auto-TH for this aMutableCursor :: Accessor Mutable Cursor aMutableCursor = convertor mutableCursor Mutable++noAcc :: Cursor -> Accessor model Mutable+noAcc cursor = reader . Mutable $ cursor new :: Orientation -> [Item model] -> Widget.New model Mutable new orientation items acc =
src/Graphics/UI/LUI/Widgets/Grid.hs view
@@ -6,6 +6,7 @@ ,Mutable(..) ,Items ,Cursor+ ,noAcc ,new ,aMutableCursor ,DelegatedMutable@@ -25,17 +26,17 @@ import Graphics.UI.LUI.Func((~>), result) import Graphics.UI.LUI.List(isSorted) import Graphics.UI.LUI.Tuple(swap)-import Graphics.UI.LUI.Accessor(Accessor, convertor, (^.), (^>), write)+import Graphics.UI.LUI.Accessor(Accessor, reader, convertor, (^.), (^>), write) import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.HaskGame.Key as Key+import qualified Graphics.UI.HaskGame.Vector2 as Vector2 import Graphics.UI.HaskGame.Key(asKeyGroup, noMods, shift) import Graphics.UI.HaskGame.Color(Color)-import Graphics.UI.HaskGame.Vector2(Vector2(..)- ,vector2fst,vector2snd)+import Graphics.UI.HaskGame.Vector2(Vector2(..)) import qualified Data.Map as Map-import Control.Arrow(second, (***))+import Control.Arrow(second) import Data.List(transpose) import Data.Maybe(isJust, isNothing, fromMaybe) import Data.Monoid(mempty, mconcat)@@ -83,8 +84,8 @@ Nothing -> Vector2 0 0 Just item -> widgetSize (itemWidget item model) (gridDrawInfo mutable itemIndex drawInfo)- rowsHeights = mapItems vector2snd rowsSizes- rowsWidths = mapItems vector2fst rowsSizes+ rowsHeights = mapItems Vector2.snd rowsSizes+ rowsWidths = mapItems Vector2.fst rowsSizes rowHeights = map maximum $ rowsHeights columnWidths = map maximum . transpose $ rowsWidths@@ -133,26 +134,38 @@ itemAt cursor = (cursor, items Map.! cursor) in map fst . filter (itemSelectable model . snd) . map itemAt $ nexts +leftKeyGroup,+ rightKeyGroup,+ upKeyGroup,+ downKeyGroup,+ nextKeyGroup,+ prevKeyGroup :: Widget.KeyAction++leftKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_LEFT)+rightKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_RIGHT)+upKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_UP)+downKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_DOWN)+nextKeyGroup = (Widget.KeyDown, asKeyGroup noMods SDL.SDLK_TAB)+prevKeyGroup = (Widget.KeyDown, asKeyGroup shift SDL.SDLK_TAB)+ keysMap :: Cursor -> model -> Mutable -> Items model -> Widget.ActionHandlers Mutable keysMap size@(sizeX, _) model mutable items =- Map.fromList $- map (((,) Widget.KeyDown) ***- second const) . concat $+ Map.fromList $ concat $ [let opts = axis size model mutable items- in cond opts (key, (desc, head opts `mutableMoveTo` mutable))+ in cond opts (key, (desc, const $ head opts `mutableMoveTo` mutable)) | (key, axis, desc) <-- [(asKeyGroup noMods SDL.SDLK_LEFT,- getSelectablesX (subtract 1), "Move left")- ,(asKeyGroup noMods SDL.SDLK_RIGHT,- getSelectablesX (+1), "Move right")- ,(asKeyGroup noMods SDL.SDLK_UP,- getSelectablesY (subtract 1), "Move up")- ,(asKeyGroup noMods SDL.SDLK_DOWN,- getSelectablesY (+1), "Move down")- ,(asKeyGroup noMods SDL.SDLK_TAB,- getSelectablesXY [0..sizeX-1] (+1), "Move to next")- ,(asKeyGroup shift SDL.SDLK_TAB,- getSelectablesXY [sizeX-1,sizeX-2..0] (subtract 1), "Move to prev")+ [(leftKeyGroup, getSelectablesX (subtract 1),+ "Move left")+ ,(rightKeyGroup, getSelectablesX (+1),+ "Move right")+ ,(upKeyGroup, getSelectablesY (subtract 1),+ "Move up")+ ,(downKeyGroup, getSelectablesY (+1),+ "Move down")+ ,(nextKeyGroup, getSelectablesXY [0..sizeX-1] (+1),+ "Move to next")+ ,(prevKeyGroup, getSelectablesXY [sizeX-1,sizeX-2..0] (subtract 1),+ "Move to prev") ] ] where@@ -165,6 +178,9 @@ posSizes sizes = let positions = scanl (+) 0 sizes in zip positions sizes++noAcc :: Cursor -> Accessor model Mutable+noAcc cursor = reader . Mutable $ cursor new :: Cursor -> Items model -> Widget.New model Mutable new size items acc model =
src/Graphics/UI/LUI/Widgets/KeysTable.hs view
@@ -20,8 +20,6 @@ import qualified Graphics.UI.HaskGame.Key as Key import Graphics.UI.LUI.Widget(Widget, widgetGetKeymap) -import Graphics.UI.LUI.Accessor(reader)- import Graphics.UI.HaskGame.Color(Color(..)) import Graphics.UI.HaskGame.Font(Font) @@ -50,7 +48,8 @@ Widget model new keysColor descColor spaceWidth keysFont descFont handlers = Unfocusable.new grid where- grid = Grid.new (3, Map.size handlers) gridItems gridAccessor+ grid = Grid.new (3, Map.size handlers) gridItems $+ Grid.noAcc (error "Unfocusable grid should never use cursor") space = Space.newW spaceWidth gridItems = Map.fromList . concat $@@ -63,7 +62,6 @@ descTextView = TextView.new descColor descFont desc ]- gridAccessor = reader $ Grid.Mutable (0,0) newForWidget :: Font -> Font -> Widget model -> Widget model newForWidget keysFont descFont widget model =@@ -74,8 +72,8 @@ newBoxedWidget :: Box.Orientation -> Int -> Font -> Font -> Widget model -> Widget model newBoxedWidget orientation space keysFont descFont widget = box where- box = Box.new orientation items . reader . Box.Mutable $ 0- items = [Box.Item widget 0.5- ,Box.Item (Space.newWH space space) 0- ,Box.Item keysTable 0]- keysTable = newForWidget keysFont descFont box+ box = Box.new orientation items $ Box.noAcc 0+ items = [Box.Item widget 0.5+ ,Box.Item (Space.newWH space space) 0+ ,Box.Item keysTable 0]+ keysTable = newForWidget keysFont descFont box
src/Graphics/UI/LUI/Widgets/Space.hs view
@@ -6,12 +6,11 @@ import qualified Graphics.UI.LUI.Widget as Widget import Graphics.UI.LUI.Widget(Widget, WidgetFuncs(..))-import Graphics.UI.HaskGame(Size) import Graphics.UI.HaskGame.Vector2(Vector2(..)) import Data.Monoid(mempty) -new :: Size -> Widget model+new :: Vector2 Int -> Widget model new size = const $ WidgetFuncs