src/Gui/textdisplay.icl

   1 implementation module textdisplay
   2
   3 import StdInt, StdList, StdMisc
   4 import StdControl, StdControlAttribute, StdControlReceiver, StdId, StdPSt, StdReceiver
   5
   6 /**     A TextDisplay is similar to a TextControl. A TextControl displays text using
   7         system settings. A TextDisplay uses the ControlPen attribute to display text.
   8         In addition, the ControlSize can be set by the programmer.
   9         The following ControlAttribute-s are inherited:
  10                 ControlMinimumSize: the minimum size of the control in case of resizing
  11                 ControlPen:         the pen settings used to display the text
  12                 ControlPos:         the layout position of the text display control
  13                 ControlResize:      resizing the control
  14                 ControlTip:         the tool tip text that must be displayed
  15 */
  16 ::      TextDisplay ls pst
  17  =      TextDisplay TextDisplayId String TextSize [ControlAttribute *(ls,pst)]
  18 ::      TextDisplayId
  19  =      {       customId        :: !Id
  20         ,       receiverId      :: !R2Id TextDisplayMsgIn TextDisplayMsgOut
  21         }
  22 ::      TextSize :== Size       // The size of the text display
  23 ::      TextDisplayMsgIn  = SetTextIn String | GetTextIn
  24 ::      TextDisplayMsgOut = SetTextOut       | GetTextOut String
  25
  26 openTextDisplayId :: !*env -> (!TextDisplayId,!*env) | Ids env
  27 openTextDisplayId env
  28         # (id,  env) = openId env
  29         # (r2id,env) = openR2Id env
  30         = ({customId=id,receiverId=r2id},env)
  31
  32 ::      TextDisplaySt
  33  =      {       text    :: !String      // The text to be displayed
  34         }
  35
  36 instance Controls TextDisplay where
  37         controlToHandles (TextDisplay {customId,receiverId} text size atts) pst
  38                 = controlToHandles textdisplay pst
  39         where
  40                 customControlSize       = validateTextDisplaySize minSize size
  41                 initDisplaySt           = { text        = text
  42                                                           }
  43                 textdisplay                     = { newLS       = initDisplaySt
  44                                                           , newDef      = CustomControl customControlSize (displaylook text) [ ControlId customId : okAtts ]
  45                                                                                         :+:
  46                                                                                   Receiver2 receiverId receiverfun []
  47                                                           }
  48                 okAtts                          = map toTextDisplayAttribute (filter isTextDisplayAttribute atts)
  49                 minSize                         = case filter isControlMinimumSize okAtts of
  50                                                                 [ControlMinimumSize s : _]      -> s
  51                                                                 _                                                       -> zero
  52
  53                 receiverfun :: !TextDisplayMsgIn !*(TextDisplaySt,PSt .ps) -> (TextDisplayMsgOut,(TextDisplaySt,PSt .ps))
  54                 receiverfun (SetTextIn str) (tdst,pst=:{io})
  55                         # tdst  = {tdst & text = str}
  56                         # io    = setControlLook customId True (True,displaylook str) io
  57                         = (SetTextOut,(tdst,{pst & io=io}))
  58                 receiverfun GetTextIn (tdst=:{text},pst)
  59                         = (GetTextOut text,(tdst,pst))
  60
  61                 displaylook :: !String !SelectState !UpdateState !*Picture -> *Picture
  62                 displaylook text _ {newFrame} picture
  63                         # picture                       = unfill newFrame picture
  64                         # (metrics,picture)     = getPenFontMetrics picture
  65                         # base                          = metrics.fAscent + metrics.fLeading
  66                         # height                        = fontLineHeight metrics
  67                         # (width,picture)       = getPenFontStringWidth text picture
  68                         # picture                       = drawAt {x=max 0 ((w-width)/2),y=(h-height)/2+base} text picture
  69                         = picture
  70                 where
  71                         {w,h}                           = rectangleSize newFrame
  72
  73         getControlType _ = "TextDisplay"
  74
  75 isTextDisplayAttribute :: !(ControlAttribute .ps) -> Bool
  76 isTextDisplayAttribute (ControlMinimumSize _)   = True
  77 isTextDisplayAttribute (ControlPen         _)   = True
  78 isTextDisplayAttribute (ControlPos         _)   = True
  79 isTextDisplayAttribute (ControlResize      _)   = True
  80 isTextDisplayAttribute (ControlTip         _)   = True
  81 isTextDisplayAttribute _                                                = False
  82
  83 toTextDisplayAttribute :: !(ControlAttribute *(.ls,.pst)) -> ControlAttribute *(TextDisplaySt,.pst)
  84 toTextDisplayAttribute (ControlMinimumSize s)   = ControlMinimumSize s
  85 toTextDisplayAttribute (ControlPen         p)   = ControlPen         p
  86 toTextDisplayAttribute (ControlPos         p)   = ControlPos         p
  87 toTextDisplayAttribute (ControlResize      f)   = ControlResize      f
  88 toTextDisplayAttribute (ControlTip         t)   = ControlTip         t
  89
  90
  91 validateTextDisplaySize :: !Size !Size -> Size
  92 validateTextDisplaySize minSize {w,h} = {w=max w (min 0 minSize.w),h=max h (min 0 minSize.h)}
  93
  94 getTextDisplayText :: !TextDisplayId !(PSt .ps) -> (!String,!PSt .ps)
  95 getTextDisplayText {receiverId} pst
  96         = case syncSend2 receiverId GetTextIn pst of
  97                 ((SendOk,Just (GetTextOut x)),pst) -> (x,pst)
  98                 other                              -> sendError "getTextDisplayText"
  99
 100 setTextDisplayText :: !TextDisplayId !String !(PSt .ps) -> PSt .ps
 101 setTextDisplayText {receiverId} newTxt pst
 102         = case syncSend2 receiverId (SetTextIn newTxt) pst of
 103                 ((SendOk,Just SetTextOut),pst) -> pst
 104                 other                          -> sendError "setTextDisplayText"
 105
 106 sendError fName
 107         = abort (fName +++ ": wrong reply from TextDisplay.\n")