Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / View < prev next >

Wrap

Text File | 1995-07-06 | 15.6 KB | 517 lines | [TEXT/MSET]

\ VIEW class. \ Oct 91 mrh Initial version. \ May 92 mrh Support for "new-style" controls \ Feb 93 mrh Added IDLE: method \ Sept 93 mrh Enhanced along lines of Newton view scheme : PtInRect { x y rptr -- b } word0 x y pack rptr call PtInRect i->l ; \ VIEW is the generic superclass for everything that can be drawn in a \ window. For example, all controls are now subclasses of view. \ In Mops a Window itself isn't a view, but contains one special view \ (the ContView) which covers the whole drawing area of the window. \ In the view, we have an ivar which is a rect, ViewRect. This is the \ rectangle defining the outer boundary of this view, relative to the \ current grafPort. This rect is used by the view to set the clip \ region and the coordinate origin before drawing. \ The ViewRect shouldn't now be set directly from a program (we don't have \ a SetViewRect: method any longer), but there is another rect, Bounds, which \ is intended to make things more convenient, since it defines the view's \ size and position relative to its parent or siblings. Whenever the parent \ view is resized, it sends MOVED: to this view, and Bounds is then used in \ conjunction with the "justification" ivars, Ljust, Tjust, Rjust and Bjust, \ to set ViewRect. \ Note that views are late-bound to, so can't appear within records. \ Here are the type definitions for the justification ivars: type{ parLeft parRight parCenter parProp sibLeft sibRight } type{ parTop parBottom dummy dummy sibTop sibBottom } 0 value MPOINT \ Point where a click occurred rect LastSibRect \ Class PtrList is used for a list of pointers which needs to be expandable. \ We will use this to implement a view's list of its children, and also \ its list of controls. We may eventually migrate it back into Mops.dic if \ it turns out to be useful enough. Also we don't have a REMOVE: method \ yet -- put it in if you need it! \ :class PTRLIST super{ string sequence } \ \ :m ADD: \ ( ptr -- ) \ pad ! pad 4 add: super ;m \ \ :m FIRST?: \ size: super NIF false EXIT THEN \ No elements - return false \ reset: super ^1st: super @ true ;m \ \ :m NEXT?: \ ( -- ptr T | -- F ) \ 4 skip: super len: super NIF false EXIT THEN \ ^1st: super @ true ;m \ \ ;class \ ============================== :class VIEW super{ object } general \ we late-bind to other views, \ thus we use "general". record { rect VIEWRECT \ Bounding rectangle, rel to grafport. rect BOUNDS \ We use this to set the viewRect ptr ^PARENT \ Points to parent (containing) view ptr ^MyWIND \ Points to owning window } ptrList CHILDREN \ List of views that this one contains \ it inherits from sequence so can't be \ in a record record { x-addr DRAW \ Draw handler x-addr ClickHndlr \ Click handler bool ALIVE? bool ENABLED? bool WantsClicks? \ True if we can accept clicks bool SetClip? \ True if we need to set the clip (default) bool MeasureFromMe? \ True if other siblings are to use this \ view for sibling relative justification \ modes byte #updates \ Counts number of pending updates byte Ljust \ Left justification byte Tjust \ Top byte Rjust \ Right byte Bjust \ Bottom } :m GETVIEWRECT: get: viewRect ;m :m GETRECT: get: viewRect ;m \ a synonym for compatibility :m ^VIEWRECT: addr: viewRect ;m \ Needed for Scroller support \ Most views can be set up at compile time using setBounds: and setJust:. \ Then at run time addView: calls must be made to establish the parent-child \ relationships. :m BOUNDS: ( -- l t r b ) get: bounds ;m :m GETBOUNDS: get: bounds ;m \ a synonym :m SETBOUNDS: ( l t r b -- ) put: bounds ;m :m GETJUST: ( -- lj tj rj bj ) get: Ljust get: Tjust get: Rjust get: Bjust ;m :m SETJUST: ( lj tj rj bj -- ) put: Bjust put: Rjust put: Tjust put: Ljust ;m :m MeasureFrom: ( b -- ) put: measureFromMe? ;m \ ADDVIEW: adds the passed-in view to this view's list of children. This \ method must be called at run time, since pointers are used, and also it has \ to be called before NEW:, since NEW: assumes the list is set up already. :m ADDVIEW: { ^view -- } ^view add: children ^base setParent: [ ^view ] ;m :m ENABLED?: get: enabled? ;m :m WINDOW: get: ^MyWind ;m :m SETWINDOW: put: ^MyWind ;m \ Normally this is only called from \ the window when setting up its \ contView. :m WANTSCLICKS: put: wantsClicks? ;m :m SETCLICK: put: ClickHndlr true put: wantsClicks? ;m :m SETDRAW: put: draw ;m :m PARENT: get: ^parent ;m :m SETPARENT: put: ^parent ;m \ UPDATE: generates an update event for the view, and CLEAR: erases it. :m UPDATE: addr: viewRect call InvalRect ;m :m CLEAR: clear: viewRect ;m private \ setting up for MOVED: :m (>VR): { left rt Pleft Prt Sleft Srt Ljust Rjust \ cent left' rt' -- left' rt' } \ Note: we're saying "left" and "right" but this routine gets used \ for top and bottom as well since the algorithm and justification \ values are exactly the same. Ljust SELECT[ parLeft ]=> left Pleft + -> left' [ parRight ]=> left Prt + -> left' [ parCenter ]=> Pleft Prt + 2/ -> cent left cent + -> left' [ parProp ]=> left Prt Pleft - 10000 */ Pleft + -> left' [ sibLeft ]=> left sleft + -> left' [ sibRight ]=> left srt + -> left' DEFAULT=> ]SELECT Rjust SELECT[ parLeft ]=> rt Pleft + -> rt' [ parRight ]=> rt Prt + -> rt' [ parCenter ]=> Pleft Prt + 2/ -> cent rt cent + -> rt' [ parProp ]=> rt Prt Pleft - 10000 */ Pleft + -> rt' [ sibLeft ]=> rt sleft + -> rt' [ sibRight ]=> rt srt + -> rt' DEFAULT=> ]SELECT left' rt' ;m :m BOUNDS>VIEWRECT: { \ bleft btop brt bbot pleft ptop prt pbot sleft stop srt sbot vleft vtop vrt vbot -- } \ First, if this is a contView, there's no parent, so we just copy \ the bounds to the viewRect and get out. nil?: ^parent IF addr: bounds ->: viewRect EXIT THEN getViewRect: [ get: ^parent ] \ Parent's viewRect -> pbot -> prt -> ptop -> pleft get: lastSibRect -> sbot -> srt -> stop -> sleft get: bounds -> bbot -> brt -> btop -> bleft bleft brt pleft prt sleft srt get: Ljust get: Rjust (>vr): self -> vrt -> vleft btop bbot ptop pbot stop sbot get: Tjust get: Bjust (>vr): self -> vbot -> vtop vleft vtop vrt vbot put: viewRect get: measureFromMe? IF addr: viewRect ->: lastSibRect THEN ;m :m ChildrenMoved: { \ l t r b -- } get: lastSibRect get: viewRect -> b -> r -> t -> l r b l t put: lastSibRect BEGIN each: children WHILE moved: [] REPEAT put: lastSibRect ;m public \ MOVED: means that something has happened to change the position of \ this view (such as the parent view moving, or the bounds or justification \ parameters changing), so we must recompute the viewRect. This means \ calling bounds>viewRect:, and calling MOVED: on our children as well. \ The situation with the clip and updating is a bit tricky - at some stage \ we should set the clip to the new view position, and probably an update \ is needed eventually as well. But in subclasses we might also have to \ erase the old position (Ctl does this, for example), which will probably \ be outside the new view area. Also we might be inside a smaller parent \ view, so setting the clip might be inappropriate. As well as this, we \ might have to do some other drawing which might make an update unnecessary. \ So here in View, we just do the basic stuff, and don't set the clip \ or update. :m MOVED: bounds>viewRect: self get: alive? IF childrenMoved: self THEN ;m \ NEW: ( -- ) fires up the view. This method in normally called \ automatically from the owning window when the window gets a NEW:. private \ Here we just factor out some stuff which subclasses can \ call, since they'll usually need it, but not all at once. \ The setupNew: operations would normally be needed at the \ start (since we have to make the viewRect valid), and the \ windupNew: ops at the end, since NEW: may draw something, \ and the child views should normally be drawn after \ the parent (so they come out on top). But this isn't a \ hard and fast rule, so we won't use callFirst/callLast \ here. :m SetupNew: bounds>viewRect: self NIL?: ^parent NIF get: ^parent window: view setWindow: self THEN ;m :m WindupNew: BEGIN ( ^base ) each: children WHILE new: [] REPEAT true put: alive? ;m public :m NEW: setupNew: self windupNew: self ;m :m RELEASE: BEGIN each: children WHILE release: [] REPEAT release: children false put: alive? ;m \ DRAW: is the method called to get the view to draw itself. There \ are a few subtleties. Before drawing is done, we "focus" which means \ setting the clip region to viewRect, and the origin so that the top left \ corner of viewRect will be (0, 0). Then after drawing, we need to call \ draw: for all the children. Now here's the good part. Both these jobs \ can be done via the CallFirst/CallLast mechanism, so the DRAW: method \ itself can just do the drawing. Here in the View class itself, this just \ consists of executing the draw handler. \ For some kinds of subview (notably Control), we may not want the origin \ change, but rather want the GrafPort origin. In these views we can just \ put "0 call SetOrigin" before the drawing code. \ Another useful point: when the draw handler is executed, tempRect will \ contain the bounding rectangle for the drawing, relative to the current \ origin. This can be used to draw a frame, for example. \ Final note: we DON'T clear the drawing area before calling the draw \ handler. If you need it cleared, you can call CLEAR: self in the draw \ handler. private :m SetTempRect: { \ left top rt bot -- } \ Sets tempRect to a view-relative version of viewRect \ -- we use this for a number of things. get: viewRect -> bot -> rt -> top -> left 0 0 rt left - bot top - put: tempRect ;m public \ SETCLIP: sets the clip before drawing. This is a rather elaborate \ process, since we need to set the clip to the intersection of this \ view's viewRect and all its parent views' viewRects (which could possibly \ be smaller). This can all be inhibited by setting SetClip? false \ (which we do when scrolling, for example, since the system has kindly \ set the clip for us already). \ Note: when this method is called, the origin has been set so that the \ top left of this view is (0,0). This is because we're going to use \ this origin for the drawing, and unless we use the same when we set the \ clip, the clip rectangle gets translated away somewhere strange! \ This method has to be public since we late-bind to it. :m SetClip: { \ ^view oLeft oTop left top rt bot -- } \ Note: origin is rel to this view. get: setClip? NIF true put: setClip? EXIT THEN get: viewRect -> bot -> rt -> top -> left left -> oLeft top -> oTop \ For origin adjustment later get: ^parent -> ^view BEGIN ^view nilP <> WHILE ^view getViewRect: view \ Msg to class for speed bot min -> bot rt min -> rt top max -> top left max -> left ^view parent: view -> ^view REPEAT left oLeft - top oTop - rt oLeft - bot oTop - put: tempRect addr: tempRect call ClipRect ;m private \ SetupDraw: is the equivalent of Focus() for a view in MacApp. \ Our CallFirst mechanism makes it automatic! :m SetupDraw: { \ left top rt bot -- port } pushPort \ Save current port get: ^myWind set: window \ and set right port for drawing 0 call SetOrigin get: viewRect -> bot -> rt -> top -> left left negate top negate pack call SetOrigin get: setClip? IF setClip: [self] ELSE true put: setClip? THEN setTempRect: self ;m :m WindupDraw: \ ( port -- ) BEGIN each: children WHILE draw: [] REPEAT 0 call SetOrigin 0 put: #updates popPort ;m public \ (DRAW): does the actual work for DRAW: - we do it this way so that \ subclasses can call (draw): super without triggering the callFirst \ and callLast code again. :m (DRAW): exec: draw ;m callFirst setupDraw: callLast windupDraw: :m DRAW: (draw): self ;m :m IDLE: \ Can be used in child views to call TEidle or whatever. BEGIN each: children WHILE idle: [] REPEAT ;m :m CLICK: \ ( -- b ) Returns true if we've handled the click. \ First we get straight out if we don't want clicks at all: get: wantsClicks? NIF false EXIT THEN \ Now we get out if the click isn't in our own area. Note that view \ subclasses can define "own area" however they like. They could \ have several non-contiguous rects, regions, anything. \ Also note that we do this check before we check if the click was in one \ of our children. This is significant, since our children can go outside \ our area (as with scrolling views). But we don't want to respond to \ clicks in the "outside" part of one of our children, since this is a \ place in the child view which doesn't really exist from the user's point \ of view. where: fEvent g->l -> mpoint mpoint unpack addr: viewRect PtInRect NIF false EXIT THEN \ not in our area - get out \ OK, it's in our area. We now look at our children first, since they \ must get first shot at the click: BEGIN each: children WHILE click: [] IF uneach: children true EXIT THEN REPEAT \ If we got here, it wasn't in the children. So we handle it here, and \ we're done: exec: clickHndlr true ;m :m KEY: \ ( c -- ) BEGIN dup each: children WHILE key: [] REPEAT drop ;m :m ENABLE: true put: enabled? BEGIN each: children WHILE enable: [] REPEAT ;m :m DISABLE: false put: enabled? BEGIN each: children WHILE disable: [] REPEAT ;m :m MouseHere?: \ ( -- b ) Returns true if the mouse is in this view. where: theMouse addr: viewRect PtInRect ;m :m CLASSINIT: true put: wantsClicks? true put: setClip? ;m :m DUMP: { \ l t r b -- } ." view " .id: self 4 spaces ." viewRect: " getViewRect: self -> b -> r -> t -> l ." left: " l . ." top: " t . ." right: " r . ." bottom: " b . cr first?: children IF ." children:" cr drop THEN BEGIN each: children WHILE 4 spaces dump: [] REPEAT ;m \ DRAWX: can be useful in debugging, when you want to see the view but \ don't have "real" drawing code yet. It just draws a big X across \ the view area, joining the diagonally opposite corners. :m DRAWX: { \ l t r b -- } get: tempRect -> b -> r -> t -> l 0 0 gotoxy r b pack call LineTo l b gotoxy r 0 pack call LineTo ;m ;class endload \ Testing: view VV \ Main view view C1 \ 5 child views view C2 view C3 view C4 view C5 40 40 300 200 setBounds: vv 10 10 20 20 setBounds: c1 true measureFrom: c1 2 0 30 60 setBounds: c2 sibRight sibBottom 2dup setJust: c2 true measureFrom: c2 2 0 20 60 setBounds: c3 sibRight sibBottom 2dup setJust: c3 true measureFrom: c3 0 2 40 60 setBounds: c4 sibRight sibBottom 2dup setJust: c4 true measureFrom: c4 : Drawit draw: tempRect ; \ Draw handler for our views : DrawVV draw: vv ; \ Draw handler for fWind for test : Clicked noclip ." clicked " .id: [self] cr ; : contentClick \ New content click handler for fWind click: vv drop ; ' drawit dup setDraw: vv dup setDraw: c1 dup setDraw: c2 dup setDraw: c3 dup setDraw: c4 setDraw: c5 ' clicked dup setclick: vv dup setclick: c1 dup setclick: c2 dup setclick: c3 dup setclick: c4 setclick: c5 : GO cls xts{ null null drawVV contentClick } actions: fWind c1 addview: vv c2 addview: vv c3 addview: vv c4 addview: vv c5 addview: vv fWind setWindow: vv \ Normally done automatically from NEW: in Window+ new: vv \ Ditto draw: vv ;