src/StdLibExt/RangeSlider.icl

   1 implementation module RangeSlider
   2
   3 import StdEnv, StdIO
   4
   5 ::      RangeSliderId a
   6         =       { sliderId      :: Id
   7                 , recId     :: R2Id (RangeSliderMsgIn a) (RangeSliderMsgOut a)
   8                 }
   9 ::      RangeSliderMsgIn a
  10         =       RSIn_GetIndex
  11         |       RSIn_GetValue
  12         |       RSIn_SetIndex RangeIndex
  13         |       RSIn_SetValue a
  14 ::      RangeSliderMsgOut a
  15         =       RSOut_GetIndex RangeIndex
  16         |       RSOut_GetValue a
  17         |       RSOut_SetIndex
  18         |       RSOut_SetValue
  19 ::      RangeSliderSt a
  20         :== Range a
  21
  22 openRangeSliderId :: !*env -> (!RangeSliderId a,!*env) | Ids env
  23 openRangeSliderId env
  24         # (sliderId,env)        = openId   env
  25         # (recId,   env)        = openR2Id env
  26         = ({sliderId=sliderId,recId=recId},env)
  27
  28 instance Controls (RangeSlider a) where
  29         controlToHandles (RangeSlider {sliderId,recId} dir width range=:{values,index} f atts) pSt
  30                 = controlToHandles impl pSt
  31         where
  32                 f`              = liftF2 f
  33                 impl    = { addLS  = range
  34                                   , addDef = SliderControl dir width state (action f`) [ControlId sliderId:map toLS atts]
  35                                                                 :+:
  36                                                      Receiver2 recId (recF f`) []
  37                                   }
  38                 state   = { sliderMin   = 0
  39                                   , sliderMax   = length values - 1
  40                                   , sliderThumb = index
  41                                   }
  42
  43                 action f move ((range=:{values,index},ls),pSt)
  44                                 = f (values!!i) (({range & index=i},ls),appPIO (setSliderThumb sliderId i) pSt)
  45                 where
  46                         i       = case move of
  47                                         SliderIncSmall                  = min (index+1)                          (length values-1)
  48                                         SliderDecSmall                  = max (index-1)                          0
  49                                         SliderIncLarge                  = min (index+(max 1 (length values)/10)) (length values-1)
  50                                         SliderDecLarge                  = max (index-(max 1 (length values)/10)) 0
  51                                         SliderThumb new                 = new
  52
  53                 recF f RSIn_GetIndex ((range=:{index},ls),pSt)
  54                         = (RSOut_GetIndex index,((range,ls),pSt))
  55                 recF f RSIn_GetValue ((range=:{values,index},ls),pSt)
  56                         = (RSOut_GetValue (values!!index),((range,ls),pSt))
  57                 recF f (RSIn_SetIndex i) ((range=:{values},ls),pSt)
  58                         = (RSOut_SetIndex,f (values!!i`) (({range & index=i`},ls),pSt))
  59                 where
  60                         i`                                                              = min (max i 0) (length values-1)
  61                 recF f (RSIn_SetValue v) ((range=:{values,index},ls),pSt)
  62                         = (RSOut_SetValue,f v (({range & values=updateAt index v values},ls),pSt))
  63
  64                 toLS (ControlActivate     f)            = ControlActivate   (liftF f)
  65                 toLS (ControlDeactivate   f)            = ControlDeactivate (liftF f)
  66                 toLS (ControlFunction     f)            = ControlFunction   (liftF f)
  67                 toLS  ControlHide                                       = ControlHide
  68                 toLS (ControlId           id)           = ControlId         id
  69                 toLS (ControlKeyboard     kF s f)       = ControlKeyboard kF s (liftF2 f)
  70                 toLS (ControlMinimumSize  s)            = ControlMinimumSize s
  71                 toLS (ControlModsFunction f)            = ControlModsFunction  (liftF2 f)
  72                 toLS (ControlMouse        mF s f)       = ControlMouse    mF s (liftF2 f)
  73                 toLS (ControlPen          p)            = ControlPen         p
  74                 toLS (ControlPos          p)            = ControlPos         p
  75                 toLS (ControlResize       f)            = ControlResize      f
  76                 toLS (ControlSelectState  s)            = ControlSelectState s
  77                 toLS (ControlTip          t)            = ControlTip         t
  78                 toLS (ControlWidth        w)            = ControlWidth       w
  79                 toLS (ControlHMargin      l r)          = ControlHMargin     l r
  80                 toLS (ControlHScroll      f)            = ControlHScroll     f
  81                 toLS (ControlItemSpace    x y)          = ControlItemSpace   x y
  82                 toLS (ControlLook         b f)          = ControlLook        b f
  83                 toLS (ControlOrigin       o)            = ControlOrigin      o
  84                 toLS (ControlOuterSize    s)            = ControlOuterSize   s
  85                 toLS (ControlViewDomain   d)            = ControlViewDomain  d
  86                 toLS (ControlViewSize     s)            = ControlViewSize    s
  87                 toLS (ControlVMargin      t b)          = ControlVMargin     t b
  88                 toLS (ControlVScroll      f)            = ControlVScroll     f
  89
  90                 liftF f ((add,ls),pSt)
  91                         # (ls,pSt)      = f (ls,pSt)
  92                         = ((add,ls),pSt)
  93
  94                 liftF2 f a ((add,ls),pSt)
  95                         # (ls,pSt)      = f a (ls,pSt)
  96                         = ((add,ls),pSt)
  97
  98         getControlType _
  99                 = "RangeSlider"
 100
 101 getRangeSliderIndex :: !(RangeSliderId a) !(PSt .ps) -> (!Maybe RangeIndex,!PSt .ps)
 102 getRangeSliderIndex {recId} pSt
 103         = case syncSend2 recId RSIn_GetIndex pSt of
 104                 ((SendOk,Just (RSOut_GetIndex i)),pSt)  = (Just i, pSt)
 105                 (_,pSt)                                                                 = (Nothing,pSt)
 106
 107 getRangeSliderValue :: !(RangeSliderId a) !(PSt .ps) -> (!Maybe a,!PSt .ps)
 108 getRangeSliderValue {recId} pSt
 109         = case syncSend2 recId RSIn_GetValue pSt of
 110                 ((SendOk,Just (RSOut_GetValue v)),pSt)  = (Just v, pSt)
 111                 (_,pSt)                                                                 = (Nothing,pSt)
 112
 113 setRangeSliderIndex :: !(RangeSliderId a) !Index !(PSt .ps) -> PSt .ps
 114 setRangeSliderIndex {recId} i pSt
 115         = snd (syncSend2 recId (RSIn_SetIndex i) pSt)
 116
 117 setRangeSliderValue :: !(RangeSliderId a) !a !(PSt .ps) -> PSt .ps
 118 setRangeSliderValue {recId} v pSt
 119         = snd (syncSend2 recId (RSIn_SetValue v) pSt)