home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / Window+ < prev   
Encoding:
Text File  |  1995-11-25  |  3.9 KB  |  175 lines  |  [TEXT/MSET]
  1. \ Window+ class - a window that supports views.
  2.  
  3. \ Oct 91    mrh    Initial version.
  4. \ May 92    mrh    "New-style" controls
  5. \ Feb 93    mrh    Added sending idle: to the contView
  6. \ Sept 93    mrh    Revised for Control now being a View subclass.
  7.  
  8. need    view
  9. need    scroller
  10.  
  11. rect    aRect
  12.  
  13. :class    WINDOW+  super{ window }
  14. record
  15. {    ptr        ^CONTVIEW        \ Points to view consisting of contents rect.
  16.     bool    ZOOMFLG
  17. }
  18.  
  19. private
  20.  
  21. :m SetContViewBounds:  { \ l t r b -- }
  22.     getRect: super  -> b -> r -> t -> l
  23.     l t r 1+ b 1+  setBounds: [ get: ^contView ]
  24.     moved: [ get: ^contView ]
  25.     0 0 32000 dup  put: tempRect  update: tempRect
  26. ;m
  27.  
  28. public
  29.  
  30. :m SETZOOM:        \ ( b -- )  Passed-in boolean indicates if this window
  31.                 \        will be  zoomable.
  32.     put: zoomFlg  ;m
  33.  
  34. :m SETVIEW:  { ^view -- }
  35.     ^view  put: ^contView  ^base setWindow: [ ^view ]  ;m
  36.  
  37. :m GETVIEW:    get: ^contView  ;m
  38.  
  39.  
  40. :m NEW:  { bndsRect tAddr tLen procID vis goAway ^view \ s255 -- }
  41.     get: alive  ?EXIT                        \ Out if already alive
  42.     ^view  setView: self
  43.     ?disable_actW: self
  44.     tAddr tLen  str255  -> s255
  45.     ^base  bndsrect  s255
  46.     vis 1 and
  47.     get: zoomFlg  8 and  procID +
  48.     inFront  goAway 1 and
  49.     0                                \ default is initially in front
  50.     get: color?
  51.     IF  NewCWindow  ELSE  NewWindow  THEN  drop
  52.     initNewWindow: self
  53.     setContViewBounds: self
  54.     new: [ get: ^contView ]                    \ Fire up view object
  55. ;m
  56.  
  57.  
  58. :m GETNEW:  { resID ^view -- }
  59.     get: alive  ?EXIT                        \ Out if already alive
  60.     ^view  setView: self
  61.     resID  getnew: super
  62.     setContViewBounds: self
  63.     new: [ get: ^contView ]                    \ Fire up view object
  64. ;m
  65.  
  66.  
  67. :m GROW:
  68.     grow: super
  69.     setContViewBounds: self  ;m
  70.  
  71. :m ZOOM:
  72.     zoom: super  set: super
  73.     setContViewBounds: self  ;m
  74.  
  75.  
  76. :m ENABLE:
  77.     enable: super        \ Note - we do this first to make sure the
  78.                         \ current grafPort is set before the views
  79.                         \ do anything.
  80.     get: ^contView  enable: []
  81. ;m
  82.  
  83. :m DISABLE:
  84.     get: ^contView  disable: []  disable: super  ;m
  85.  
  86. :m (DRAW):
  87.     (draw): super
  88.     get: ^contview  draw: []  ;m
  89.  
  90. :m DRAW:    (draw): self
  91.             ( noclip )  ;m        \ It seems that when I have scroll bars the
  92.                             \  grow icon gets clipped out unless I call
  93.                             \  noClip here.  (The callLast routine
  94.                             \  windupDraw: is where it's actually drawn).
  95.  
  96. \ IDLE: calls IDLE: on the contView (which will lead to it being called on
  97. \ all views).  We ensure this window is the current Grafport, since the views
  98. \ might want to look at the mouse position in local coordinates.
  99.  
  100. :m IDLE:    idle: super
  101.             pushPort  set: self
  102.             get: ^contView  idle: []
  103.             popPort  ;m
  104.  
  105.  
  106. :m CLOSE:        \ Disposes of window's controls and closes the window
  107.     get: ^contView  release: **
  108.     close: super  ;m
  109.  
  110.  
  111. :m CONTENT:        \ Handles a content click
  112.     active: self
  113.     IF        noClip  get: ^contView  click: **  drop
  114.     ELSE    select: self
  115.     THEN  ;m
  116.  
  117.  
  118. :m KEY:        \ ( c -- )  For typed keys, we'll send a KEY: to the
  119.             \ contView and thus to all the views.  They can do
  120.             \ whatever they like with it.
  121.     get: ^contView  key: **  ;m
  122.     
  123.  
  124. :m TEST:  { ^view -- }
  125.     screenbits true setGrow: self
  126.     true  setZoom: self
  127.     100 100 400 200 put: aRect        \ can't use tempRect - gets clobbered
  128.     aRect  " Test"  docWind  true true  ^view  new: self  ;m
  129.  
  130. :m TESTR:  { resID ^view -- }
  131.     screenbits true setGrow: self
  132.     true  setZoom: self
  133.     resID ^view  getnew: self  ;m
  134.  
  135. ;class
  136.  
  137.  
  138. endload
  139.  
  140.  
  141. \ TESTING:
  142.  
  143. window+        WW
  144. scroller    S1                            \ This will be the contview of WW
  145. scroller    S2                            \ A child of S1 - another scroller!
  146.             20 20  150 200   setBounds: s2
  147.  
  148. view        VV                            \ A child of S2
  149.             32 32  628 328  setBounds: vv
  150.  
  151.    screenbits    true  setGrow: ww
  152.                 true  setZoom: ww
  153.  
  154. : DRW  { \ l t r b -- }        \ Draws a big X across the view area.
  155.     ( clear: temprect )  get: tempRect  -> b  -> r  -> t  -> l
  156.     0 0 gotoxy  r b pack call LineTo
  157.     l b gotoxy  r 0 pack call LineTo  ;
  158.  
  159. ' drw  setDraw: vv
  160.  
  161.  
  162. : CLICK1        ." clicked s1!" cr  ;
  163. : CLICK2        ." clicked s2!" cr  ;
  164.  
  165. ' click1   setClick: s1     ' click2   setClick: s2
  166.  
  167. : GO
  168.     vv addView: s2  s2  addView: s1
  169.     s1 test: ww  ;
  170.     
  171. : GORES
  172.     vv addView: s2  s2  addView: s1
  173.     256 s1 testR: ww  ;
  174.  
  175.