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