home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Toolbox Classes / Ctl < prev    next >
Encoding:
Text File  |  1993-06-17  |  5.0 KB  |  164 lines  |  [TEXT/YERK]
  1. \  4/16/84  NDI Version 1.0
  2. \  5/07/84  NDI Convert to CALL:
  3. \  6/22/84  NDI add INIT:, change new, modify struct
  4. \  8/19/84  CBD added FindCtl
  5. \ 12/16/84  cbd VsCtl is separate from Control
  6. \  1/31/87    rfl added myWindow and myValue; new: window: put: get: classinit:
  7. \  6/02/87  rfl changed width of rect to 20+ in x from 17+
  8. \  1/19/88    rfl added getnew settitle gettitle
  9. \  9/01/88    rfl    changed back to 17 and added dim: undim:
  10. \  9/11/88    rfl    dim: to disable, undim: to enable:
  11. \ 12/14/90    rfl    removed initfont in new: and getnew: and added saveFont, restFont
  12. \ 12/18/91    rfl    resID now IVAR..getnew requires nothing on stack. must window: first
  13. \  6/24/92    rfl    putwindow and getwindow methods added for consistency to other code
  14. \  8/09/92    rfl    added frame: to draw default frame around the control
  15. \  5/13/93    rfl    protected getnew:
  16. \  6/17/93    rfl    added offset:
  17.  
  18. Decimal
  19.  
  20. 0 variable fontBuf 4 allot
  21. : savefont ( wind -- ) 68 + fontBuf 8 cmove ;
  22. : restfont ( wind -- ) fontBuf swap 68 + 8 cmove ;
  23.  
  24. \ ( ctlhndl -- objptr )  get rel ptr to ctl obj from ctl rec
  25. : Get-ctl-obj     0 swap  call GetCRefCon ;
  26.  
  27. \ ( objptr ctlhndl -- )  set rel ptr to ctl obj in ctl rec
  28. : Set-ctl-obj     swap call SetCRefCon ;
  29.  
  30. \ ( addr len -- width )  return width of string in current font
  31. : tWidth  str255 >R word0 R> call StringWidth word0  ;
  32.  
  33.  0 constant buttonID    \ control types
  34.  1 constant checkID
  35.  2 constant radioID
  36. 16 constant VsID
  37.  
  38. \ basic control class for simple controls - buttons, etc.
  39. :CLASS Control  <Super Object
  40.  
  41.     Int        procid
  42.     Handle    ctlHndl
  43.     Var        action
  44.     Int        myValue
  45.     Var        myWindow
  46.     Int        resID
  47.  
  48.     \ ( n -- )
  49.     :M PUTRESID: put: resID ;M
  50.  
  51.     \ ( part# -- )  perform action for control
  52.     :M  EXEC:  IF exec: action THEN  ;M
  53.  
  54.     \ ( -- l t r b )  stack bounds rectangle
  55.     :M  GETRECT:  ptr: ctlhndl  8+  get: rect  ;M
  56.  
  57.     \ ( -- )  cause the control to be drawn
  58.     :M  UPDATE:   Ptr: CtlHndl  8+  +base call InvalRect   ;M
  59.  
  60.     :M  HIDE:   Get: Ctlhndl   call HideControl    ;M
  61.  
  62.     :M  SHOW:   Get: Ctlhndl   call ShowControl    ;M
  63.  
  64.     \ ( x y -- )  Move control to x,y location
  65.     :M  MOVETO:  pack get: ctlhndl swap call MoveControl ;M
  66.  
  67.     \ ( dx dy -- ) Offset from current x,y by dx,dy
  68.     :M  OFFSET: { dx dy \ x y -- } getRect: self 2drop -> y -> x
  69.         dx x + dy y + moveto: self ;M
  70.  
  71.     \ ( w h -- )  set width, height of control's rect
  72.     :M  SIZE:  pack get: ctlhndl swap call SizeControl  ;M
  73.  
  74.     \ ( procid -- )  initialize
  75.     :M  INIT:  put: procid   ;M
  76.  
  77.     \ ( window -- ) use this to initialize the owning window
  78.     :M    WINDOW:  put: myWindow ;M
  79.  
  80.     :M  PUTWINDOW: put: myWindow ;M
  81.  
  82.     :M  GETWINDOW: get: myWindow ;M
  83.  
  84.     \ ( cfa -- )  set the action for this control
  85.     :M  ACTIONS:  put: action  ;M
  86.  
  87.     \ ( value -- )  set ctl value
  88.     :M    PUT:  { theVal -- } alive: [ obj: myWindow ]
  89.         IF theVal get: ctlhndl  swap makeint call SetCtlValue THEN
  90.         theVal put: myValue ;M
  91.  
  92.     \ ( -- val)  some ctls may need original value, eg scroll bar
  93.     :M    GET:  alive: [ obj: myWindow ]
  94.         IF w 0 get: ctlhndl call getCtlValue word0
  95.         ELSE get: myValue
  96.         THEN ;M
  97.  
  98.     \ build a control on the heap
  99.     :M  NEW:  { x y addr len theWind \ tWid -- }
  100.         theWind saveFont
  101.         get: procID 8 and 0=    \ window font if true
  102.         IF  0 tFont 12 tSize THEN  addr len tWidth -> tWid    \ width of title
  103.         x y  x tWid + 17 + y 17 + put: tempRect
  104.         0 abs: theWind  Abs: tempRect addr len str255
  105.         w 256 word0 word0 w 1  Int: procid  ^base
  106.         call NewControl put: ctlhndl
  107.         ^base get: ctlhndl set-ctl-obj
  108.         theWind put: myWindow get: myValue put: self theWind restFont ;M
  109.  
  110.      :M getnew: { \ theWind -- } get: myWindow -> theWind
  111.         theWind 0= classerr" 157 theWind saveFont
  112.         0 int: resID theWind +base call getNewControl dup 0= classerr" 170
  113.         put: ctlhndl
  114.         ^base get: ctlhndl set-ctl-obj
  115.         theWind put: myWindow get: myValue put: self theWind restFont ;M
  116.  
  117.     \ ( -- ctlhndl )
  118.     :M  HANDLE:  Get: CtlHndl  ;M
  119.  
  120.     \ ( hiliteState -- )  Hilite a part or entire control
  121.     :M  HILITE:  get: ctlhndl  swap makeInt
  122.         call HiliteControl    ;M
  123.  
  124.     :M  DISABLE: -1 hilite: self ;M
  125.     :M  ENABLE: 0 hilite: self ;M
  126.  
  127.     \ draws a border around a control to signify the default button.
  128.     :M  FRAME: pushPort set: [ obj: myWindow ] 3 3 pack call PenSize
  129.          getRect: self put: tempRect
  130.          -4 -4 inset: tempRect
  131.          abs: tempRect 16 16 pack call FrameRoundRect call penNormal popPort ;M
  132.  
  133.     \ ( addr len -- )
  134.     :M  setTitle: str255 get: ctlhndl swap call setCTitle ;M
  135.  
  136.     \ ( -- addr len )
  137.     :M  getTitle: get: ctlhndl pad +base call getCTitle pad count ;M
  138.     \ ( -- )
  139.     :M  CLOSE:    Get: Ctlhndl call DisposControl  ;M
  140.  
  141.     \ ( -- )  set default control to a standard button
  142.     :M  CLASSINIT:  buttonID init: self 'c null actions: self  ;M
  143.  
  144.     \ ( ^wind -- )  show an example button
  145.     :M  EXAMPLE: { thewind -- }  200 100 " Button"
  146.         theWind new: self  update: self  ;M
  147.  
  148. ;CLASS
  149.  
  150. 0 variable  theCtl
  151.  
  152. \ control part codes
  153. 10  constant inButton        \ simple button
  154. 11  constant inCheckBox        \ check or radio
  155. 129 constant inThumb
  156. 20  constant inUpButton        \ up arrow in scroll bar
  157. 21  constant inDownButton    \ down arrow
  158. 22  constant inPageUp
  159. 23  constant inPageDown
  160.  
  161. \ add to ID if title in application font
  162. 8 constant useWFont
  163.  
  164.