Commit 40f726b0 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

Initial import (version 0.0.4a)

parent f3b2faeb
definition module
BalancedText
import
StdInt,
StdString,
StdPictureDef,
StdControlClass,
StdWindowDef
:: BalancedTextAttribute =
BalancedTextColour !Colour
| BalancedTextBackgroundColour !Colour
| BalancedTextFont !FontDef
| BalancedTextFontSize !Int
| BalancedTextFontStyle ![String]
| BalancedTextFontFace !String
BalancedTextControl :: !String !Int ![BalancedTextAttribute] ![ControlAttribute *(.ls, .ps)] -> BalancedTextState .ls .ps
BalancedTextWindow :: !String !String !Int !Size ![BalancedTextAttribute] ![WindowAttribute *(Int, *PSt .ps)] !*(PSt .ps) -> *PSt .ps
instance Controls BalancedTextState
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
:: BalancedTextState ls ps =
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
{ batText :: !String
, batWidth :: !Int
, batCustomAttributes :: ![BalancedTextAttribute]
, batControlAttributes :: ![ControlAttribute *(ls, ps)]
}
\ No newline at end of file
implementation module
BalancedText
import
StdEnv,
StdIO,
MdM_IOlib
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
:: BalancedTextAttribute =
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
BalancedTextColour !Colour
| BalancedTextBackgroundColour !Colour
| BalancedTextFont !FontDef
| BalancedTextFontSize !Int
| BalancedTextFontStyle ![String]
| BalancedTextFontFace !String
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
:: BalancedTextState ls ps =
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
{ batText :: !String
, batWidth :: !Int
, batCustomAttributes :: ![BalancedTextAttribute]
, batControlAttributes :: ![ControlAttribute *(ls, ps)]
}
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
BalancedTextControl :: !String !Int ![BalancedTextAttribute] ![ControlAttribute *(.ls, .ps)] -> BalancedTextState .ls .ps
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
BalancedTextControl text width custom_attributes control_attributes
= { batText = text
, batWidth = width
, batCustomAttributes = custom_attributes
, batControlAttributes = control_attributes
}
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
BalancedTextWindow :: !String !String !Int !Size ![BalancedTextAttribute] ![WindowAttribute *(Int, *PSt .ps)] !*(PSt .ps) -> *PSt .ps
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
BalancedTextWindow title text width windowsize custom_attributes window_attributes state
# (fontdef, colour, bgcolour, state) = getAttributesInfo custom_attributes state
# ((_, font), state) = accPIO (accScreenPicture (openFont fontdef)) state
# (fontmetrics, state) = accPIO (accScreenPicture (getFontMetrics font)) state
# baseline = fontmetrics.fAscent + fontmetrics.fDescent
# skip = baseline + fontmetrics.fLeading
# (drawfuns, state) = computeDrawFunctions font baseline skip colour width zero (breakIntoWords text) state
# (maxx, maxy) = getMaxXY (map fst drawfuns)
# the_window = Window title NilLS
([ WindowViewSize windowsize
, WindowViewDomain {corner1=zero, corner2={x=maxx, y=maxy}}
, WindowLook True (SmartLook drawfuns bgcolour)
, WindowHScroll (ScrollFunction 10 85 Horizontal id)
, WindowVScroll (ScrollFunction 10 85 Vertical id)
] ++ window_attributes)
= snd (openWindow 0 the_window state)
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
getAttributesInfo :: ![BalancedTextAttribute] !*(PSt .ps) -> (!FontDef, !Colour, !Colour, !*PSt .ps)
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
getAttributesInfo attrs state
# (font, state) = accPIO (accScreenPicture openDefaultFont) state
# (fontdef, colour, bgcolour) = get_info "" 0 [] Black White (getFontDef font) attrs
= (fontdef, colour, bgcolour, state)
where
get_info _ size styles colour bgcolour fontdef [BalancedTextFontFace face : attrs] = get_info face size styles colour bgcolour fontdef attrs
get_info face _ styles colour bgcolour fontdef [BalancedTextFontSize size : attrs] = get_info face size styles colour bgcolour fontdef attrs
get_info face size _ colour bgcolour fontdef [BalancedTextFontStyle styles : attrs] = get_info face size styles colour bgcolour fontdef attrs
get_info face size styles _ bgcolour fontdef [BalancedTextColour colour : attrs] = get_info face size styles colour bgcolour fontdef attrs
get_info face size styles colour _ fontdef [BalancedTextBackgroundColour bgcolour: attrs] = get_info face size styles colour bgcolour fontdef attrs
get_info face size styles colour bgcolour _ [BalancedTextFont fontdef : attrs] = get_info face size styles colour bgcolour fontdef attrs
get_info face size styles colour bgcolour fontdef []
# new_size = if (size == 0) fontdef.fSize size
# new_face = if (face == "") fontdef.fName face
# new_styles = if (isEmpty styles) fontdef.fStyles styles
= ({fSize = new_size, fName = new_face, fStyles = new_styles}, colour, bgcolour)
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
getMaxXY :: ![Rectangle] -> (!Int, !Int)
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
getMaxXY rectangles
| isEmpty rectangles = (0, 0)
= (maxList [rec.corner2.x \\ rec <- rectangles], maxList [rec.corner2.y \\ rec <- rectangles])
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
computeDrawFunctions :: !Font !Int !Int !Colour !Int !Point2 ![String] !*(PSt .ps) -> (![(Rectangle, *Picture -> *Picture)], !*PSt .ps)
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
computeDrawFunctions font baseline skip colour width {x,y} [word: words] state
# (word_width, state) = accPIO (accScreenPicture (getFontStringWidth font word)) state
# (space_width, state) = accPIO (accScreenPicture (getFontCharWidth font ' ')) state
# (newpoint, drawword) = case x + word_width <= width of
True -> fitWord font baseline skip colour width {x=x,y=y} word_width space_width word
False -> nofitWord font baseline skip colour width {x=x,y=y} word_width space_width word
# (drawwords, state) = computeDrawFunctions font baseline skip colour width newpoint words state
= ([drawword: drawwords], state)
where
// ----------------------------------------------------------------------------------------------------------------
fitWord :: !Font !Int !Int !Colour !Int !Point2 !Int !Int !String -> (!Point2, !(!Rectangle, !*Picture -> *Picture))
// ----------------------------------------------------------------------------------------------------------------
fitWord font baseline skip colour width {x,y} word_width space_width word
# drawword = seq [setPenFont font, setPenColour colour, drawAt {x=x,y=y+baseline} word]
# drawrectangle = {corner1 = {x=x,y=y}, corner2 = {x=x+word_width,y=y+skip}}
# (newx, newy) = case x+word_width+space_width <= width of
True -> (x+word_width+space_width, y)
False -> (0, y+skip)
= ({x=newx, y=newy}, (drawrectangle, drawword))
// ------------------------------------------------------------------------------------------------------------------
nofitWord :: !Font !Int !Int !Colour !Int !Point2 !Int !Int !String -> (!Point2, !(!Rectangle, !*Picture -> *Picture))
// ------------------------------------------------------------------------------------------------------------------
nofitWord font baseline skip colour width {x,y} word_width space_width word
# drawword = seq [setPenFont font, setPenColour colour, drawAt {x=0,y=y+skip+baseline} word]
# drawrectangle = {corner1 = {x=0,y=y+skip}, corner2 = {x=word_width,y=y+skip+skip}}
# (newx, newy) = (word_width + space_width, y+skip)
= ({x=newx, y=newy}, (drawrectangle, drawword))
computeDrawFunctions font baseline skip colour width {x,y} [] state
= ([], state)
/*
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
efficientLook :: !Colour [(!Rectangle, *Picture -> *Picture)] !SelectState !UpdateState -> (*Picture -> *Picture)
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
efficientLook bgcolour drawfuns _ {oldFrame, newFrame, updArea}
= get_all_draws bgcolour updArea drawfuns
where
// ------------------------------------------------------------------------------------
get_draws :: !Rectangle [(!Rectangle, *Picture -> *Picture)] -> (*Picture -> *Picture)
// ------------------------------------------------------------------------------------
get_draws updArea [(area, drawfun): drawfuns]
# corner1_x_in_range = area.corner1.x >= area.corner1.x && area.corner1.x <= area.corner2.x
# corner2_x_in_range = area.corner2.x >= area.corner1.x && area.corner2.x <= area.corner2.x
# corner1_y_in_range = area.corner1.y >= area.corner1.y && area.corner1.y <= area.corner2.y
# corner2_y_in_range = area.corner2.y >= area.corner1.y && area.corner2.y <= area.corner2.y
# overlap = (corner1_x_in_range || corner2_x_in_range) && (corner1_y_in_range || corner2_y_in_range)
| overlap = seq [drawfun, get_draws updArea drawfuns]
| otherwise = get_draws updArea drawfuns
get_draws updArea []
= id
// --------------------------------------------------------------------------------------------------
get_all_draws :: !Colour [!Rectangle] [(!Rectangle, *Picture -> *Picture)] -> (*Picture -> *Picture)
// --------------------------------------------------------------------------------------------------
get_all_draws bgcolour [area: areas] drawfuns
# draw_background = seq [setPenColour bgcolour, fill area]
# draw_one = get_draws area drawfuns
# draw_others = get_all_draws bgcolour areas drawfuns
= seq [draw_background, draw_one, draw_others]
get_all_draws bgcolour [] drawfuns
= id
*/
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
instance Controls BalancedTextState
// ---------------------------------------------------------------------------------------------------------------------------------------------------------------------
where
getControlType _ = "BalancedTextControl"
controlToHandles bstate state
# (fontdef, colour, bgcolour, state) = getAttributesInfo bstate.batCustomAttributes state
# ((_, font), state) = accPIO (accScreenPicture (openFont fontdef)) state
# (fontmetrics, state) = accPIO (accScreenPicture (getFontMetrics font)) state
# baseline = fontmetrics.fAscent + fontmetrics.fDescent
# skip = baseline + fontmetrics.fLeading
# (drawfuns, state) = computeDrawFunctions font baseline skip colour bstate.batWidth zero (breakIntoWords bstate.batText) state
# (maxx, maxy) = getMaxXY (map fst drawfuns)
# the_control = CompoundControl NilLS
([ ControlViewSize {w=maxx,h=maxy}
, ControlLook True (SmartLook drawfuns bgcolour)
] ++ bstate.batControlAttributes)
= controlToHandles the_control state
module
Example
import
StdEnv,
StdIO,
BalancedText
ExampleDialog
= Dialog "Example dialog - close to exit example program"
( BalancedTextControl "The dialog will be of the same width as this text. (which is approx. 350)" 350
[]
[]
:+: BalancedTextControl "And this longer text will be adjusted as much as possible to fit this width. This includes spanning multiple lines. " 350
[ BalancedTextColour Red
, BalancedTextBackgroundColour Black
, BalancedTextFontSize 12
, BalancedTextFontFace "Comic Sans MS"
, BalancedTextFontStyle ["bold"]
]
[ ControlPos (Left, zero)
]
) [WindowClose (noLS closeProcess)]
LargeDialog
= Window "Large window - test update speed"
( BalancedTextControl (foldr (+++) "" (repeatn 500 "Hallo ")) 650 [] []
)
[]
Start :: *World -> *World
Start world
= startIO MDI 0 initialize [ProcessClose closeProcess] world
where
initialize :: (*PSt .ps) -> *PSt .ps
initialize state
# (_, state) = openDialog 0 ExampleDialog state
# (_, state) = openDialog 0 ExampleDialog state
# many_hallos = foldr (+++) "" (repeatn 500 "Hallo ")
# state = BalancedTextWindow "TEST window" many_hallos 500 {w=300,h=100} [] [] state
= state
This diff is collapsed.
definition module
ErrorHandler
import
StdEnv,
StdPSt
:: HandlerError a :== ![a]
:: ErrorShortMessage a :== a -> String
:: ErrorLongMessage a :== a -> String
OK :== []
isOK :: !(HandlerError a) -> Bool
isError :: !(HandlerError a) -> Bool
pushError :: !a !(HandlerError a) -> HandlerError a
ErrorHandler :: !(ErrorShortMessage a) !(ErrorLongMessage a) !Bool !(HandlerError a) ![String] !*(PSt .ps) -> (!String, !*PSt .ps)
TruncPath :: !String -> !String
TruncExtension :: !String -> !String
smap :: !(.a -> .b) !.[.a] -> .[.b]
umap :: !(.a -> (.s -> (.c, .s))) !.[.a] !.s -> (!.[.c], !.s)
uwalk :: !(.a -> (.s -> .s)) !.[.a] !.s -> .s
uuwalk :: !(.a -> .(.s1 -> .(.s2 -> (.s1, .s2)))) ![.a] !.s1 !.s2 -> (!.s1, !.s2)
mapError :: !(.a -> (HandlerError b, .c)) !.[.a] -> (!HandlerError b, !.[.c])
umapError :: !(.a -> (.s -> (HandlerError b, .c, .s))) !.[.a] !.s -> (!HandlerError b, !.[.c], !.s)
uumapError :: !(.a -> .(.s1 -> .(.s2 -> (HandlerError b, .c, .s1, .s2)))) !.[.a] !.s1 !.s2 -> (!HandlerError b, !.[.c], !.s1, !.s2)
uumap :: !(.a -> .(.s1 -> .(.s2 -> (.c, .s1, .s2)))) !.[.a] !.s1 !.s2 -> (!.[.c], !.s1, !.s2)
uwalkError :: !(.a -> (.s -> (HandlerError b, .s))) !.[.a] !.s -> (!HandlerError b, !.s)
uuwalkError :: !(.a -> .(.s1 -> .(.s2 -> (HandlerError b, .s1, .s2)))) !.[.a] !.s1 !.s2 -> (!HandlerError b, !.s1, !.s2)
useqError :: ![.a -> (HandlerError b, .a)] !.a -> (!HandlerError b, !.a)
ufilter :: !(a .s -> (!Bool, .s)) ![a] !.s -> (![a], !.s)
implementation module
ErrorHandler
import
StdEnv,
StdIO,
MarkUpText,
BalancedText,
ControlMaybe
, RWSDebug
// ---------------------------------------------------------------------------------------------------------
:: HandlerError a :== ![a]
:: ErrorShortMessage a :== a -> String
:: ErrorLongMessage a :== a -> String
// ---------------------------------------------------------------------------------------------------------
// ---------------------------------------------------------------------------------------------------------
OK :== []
// ---------------------------------------------------------------------------------------------------------
// ---------------------------------------------------------------------------------------------------------
isOK :: !(HandlerError a) -> Bool
// ---------------------------------------------------------------------------------------------------------
isOK [error:errors]
= False
isOK []
= True
// ---------------------------------------------------------------------------------------------------------
isError :: !(HandlerError a) -> Bool
// ---------------------------------------------------------------------------------------------------------
isError [error:errors]
= True
isError []
= False
// ---------------------------------------------------------------------------------------------------------
pushError :: !a !(HandlerError a) -> HandlerError a
// ---------------------------------------------------------------------------------------------------------
pushError error errors
= [error: errors]
// ---------------------------------------------------------------------------------------------------------
ErrorHandler :: !(ErrorShortMessage a) !(ErrorLongMessage a) !Bool !(HandlerError a) ![String] !*(PSt .ps)
-> (!String, !*PSt .ps)
// ---------------------------------------------------------------------------------------------------------
ErrorHandler _ _ _ [] _ pstate
= ("", pstate)
ErrorHandler make_short_msg make_long_msg fatal [error:errors] buttons pstate
# title = make_short_msg error
# explanation = make_long_msg error
# details = map make_short_msg errors
# (mb_bitmap, pstate) = accFiles (openBitmap (applicationpath "Images/ErrorImage.bmp")) pstate
# (dialog_id, pstate) = accPIO openId pstate
# (button_ids, pstate) = accPIO (openIds (length buttons)) pstate
# (dialog, pstate) = ErrorDialog fatal title explanation details mb_bitmap buttons dialog_id button_ids pstate
# ((_, mb_button), pstate) = openModalDialog (hd buttons) dialog pstate
= case mb_button of
Nothing -> ("", pstate)
(Just msg) -> (msg, pstate)
// ---------------------------------------------------------------------------------------------------------
AlmostBG :== RGB {r=230, g=170, b=170}
BG :== RGB {r=210, g=140, b=140}
TitleFG :== RGB {r=150, g= 0, b= 0}
GreenBG :== RGB {r=140, g=210, b=140}
// ---------------------------------------------------------------------------------------------------------
// ---------------------------------------------------------------------------------------------------------
// ErrorDialog
// ---------------------------------------------------------------------------------------------------------
ErrorDialog fatal title explanation details mb_bitmap buttons dialog_id button_ids pstate
# bg = if fatal BG GreenBG
# start_control = bitmap_control :+: title_control bg :+: bitmap_control
# (real_size, pstate) = controlSize start_control False (Just (5,5)) (Just (5,5)) (Just (15,15)) pstate
= (
Dialog "Error!"
(CompoundControl (start_control :+: explanation_control (real_size.w) bg :+: (details_control details real_size.w bg) :+: (ListLS (button_controls buttons button_ids)))
[ ControlItemSpace 15 15
, ControlHMargin 5 5
, ControlVMargin 5 5
, ControlLook False (\_ {newFrame} -> seq [setPenColour bg, fill newFrame])
])
[ WindowId dialog_id
, WindowHMargin 0 0
, WindowVMargin 0 0
, WindowClose (noLS (closeWindow dialog_id))
, WindowOk (hd button_ids)
, WindowCancel (hd button_ids)
, WindowInitActive (hd button_ids)
]
, pstate)
where
bitmap_control
= CustomControl bitmap_size (\_ _ -> bitmap_draw)
[]
where
bitmap_size = if (isNothing mb_bitmap) {w=0,h=0} (getBitmapSize (fromJust mb_bitmap))
bitmap_draw = if (isNothing mb_bitmap) (\pict->pict) (seq [setPenColour BG, setPenBack BG, draw (fromJust mb_bitmap)])
title_control bg
= BalancedTextControl title 500
[ BalancedTextFontSize 11
, BalancedTextColour TitleFG
, BalancedTextBackgroundColour bg
, BalancedTextFontStyle ["Bold"]
, BalancedTextFontFace "Comic Sans MS"
]
[]
explanation_control w bg
= BalancedTextControl explanation w
[ BalancedTextColour Blue
, BalancedTextFontSize 10
, BalancedTextBackgroundColour bg
, BalancedTextFontStyle ["Bold"]
, BalancedTextFontFace "Times New Roman"
]
[ ControlPos (Center, zero)
]
details_control [] w bg
= ControlNothing
details_control errors w bg
= ControlJust
( boxedMarkUp Black DoNotResize [CmBText "Underlying errors:", CmNewline: ferrors]
[ MarkUpWidth w
, MarkUpNrLines (min 11 (length details+1))
, MarkUpFontFace "Times New Roman"
, MarkUpTextSize 8
, MarkUpTextColour Grey
, MarkUpBackgroundColour AlmostBG
, MarkUpVScroll
, MarkUpHScroll
]
[ ControlPos (Center, zero)
]
)
where
ferrors
= flatten (map (\text -> [CmIText text, CmNewline]) errors)
button_controls [] []
= []
button_controls [name:names] [id:ids]
# pos = if (isEmpty ids) (Right, OffsetVector {vx=0,vy=5}) (LeftOf (hd ids), OffsetVector {vx=10,vy=0})
# control = ButtonControl name
[ ControlPos pos
, ControlId id
, ControlFunction (close name)
]
= [control: button_controls names ids]
close :: !String !(!String, !*PSt .ls) -> (!String, !*PSt .ls)
close button (_, pstate)
= (button, closeWindow dialog_id pstate)
// -----------------------------------------------------------------------------------------
umap :: !(.a -> (.s -> (.c, .s))) !.[.a] !.s -> (!.[.c], !.s)
// -----------------------------------------------------------------------------------------
umap f [] state
= ([], state)
umap f [x:xs] state
#! (fx, state) = f x state
#! (fxs, state) = umap f xs state
= ([fx:fxs], state)
// ---------------------------------------------------------------------------------------------------------
uumap :: !(.a -> .(.s1 -> .(.s2 -> (.c, .s1, .s2)))) !.[.a] !.s1 !.s2 -> (!.[.c], !.s1, !.s2)
// ---------------------------------------------------------------------------------------------------------
uumap f [] state1 state2
= ([], state1, state2)
uumap f [x:xs] state1 state2
#! (fx, state1, state2) = f x state1 state2
#! (fxs, state1, state2) = uumap f xs state1 state2
= ([fx:fxs], state1, state2)
// ---------------------------------------------------------------------------------------------------------
uwalk :: !(.a -> (.s -> .s)) !.[.a] !.s -> .s
// ---------------------------------------------------------------------------------------------------------
uwalk f [] state
= state
uwalk f [x:xs] state
#! state = f x state
= uwalk f xs state
// ---------------------------------------------------------------------------------------------------------
uuwalk :: !(.a -> .(.s1 -> .(.s2 -> (.s1, .s2)))) ![.a] !.s1 !.s2 -> (!.s1, !.s2)
// ---------------------------------------------------------------------------------------------------------
uuwalk f [] state1 state2
= (state1, state2)
uuwalk f [x:xs] state1 state2
#! (state1, state2) = f x state1 state2
= uuwalk f xs state1 state2
// ---------------------------------------------------------------------------------------------------------
TruncPath :: !String -> !String
// ---------------------------------------------------------------------------------------------------------
TruncPath text
# list = [c \\ c <-: text]
# reverse_list = reverse list
# reverse_filename = takeWhile (\c -> c <> '\\' && c <> '/') reverse_list
= toString (reverse reverse_filename)