Celestin Apprentice 4

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

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Module source / windowmod.txt < prev next >

Wrap

Text File | 1995-12-05 | 10.9 KB | 429 lines | [TEXT/MSET]

\ Window class. \ May 91 mrh Added NonScrollWind. \ Default grow and drag limits set at grow and drag time. \ Also fixed a number of long-standing bugs in draw:, enable:, disable: \ etc. New: deactivates current window. Added PenIntoWind:. \ Nov95 JRF Option to not outline unused scroll bars \ =================================== \ WINDOW is the basic window class, with no controls. \ For windows with controls, use Window+. \ =================================== :class WINDOW super{ grafPort } record { $ 20 bytes wind1 \ unmapped handle CTLLIST \ 1st ctl $ 0C bytes wind2 \ unmapped rect CONTRECT \ true content rect GROWRECT \ grow size rectangle rect DRAGRECT \ drag limits rect bool GROWFLG \ true if growable bool DRAGFLG \ true if draggable bool ALIVE \ true if space exists bool SCROLLFLG \ true if scrollable bool COLOR? \ true if this is a color window x-addr IDLE \ idle handler x-addr DEACT \ deactivate event handler x-addr CONTENT \ content handler x-addr DRAW \ draw handler x-addr ENACT \ activate event handler x-addr CLOSE \ close handler int RESID \ resource id bool ClipGrowLeft \ Nov95 JRF Option to not outline unused HScroll bool ClipGrowTop \ ditto unused VScroll -- DrawGrowIcon normally } private :m SETLIMITS: \ Sets GrowRect and DragRect to reasonable default values \ according to the current screen size at the time the grow \ or drag is done. Programs such as SteppingOut can change \ the screen size while a window is open! screenbits put: dragRect 40 40 getBot: dragRect put: growRect 4 4 inset: dragRect ;m :m ?SETFPRECT: \ Sets fPrect if scrollFlg is true. fPrect is needed by \ the nucleus for scrolling fWind, before proper window \ handling is loaded. But it can be used for scrolling \ text in any other window as well, if scrolling is enabled \ for that window. get: scrollFlg IF get: contRect put: fPrect THEN ;m :m ?DISABLE_ACTW: \ Deactivates the currently active window before a New: \ or GetNew: call, if there is a currently active Mops \ window. actW 0EXIT disable: [ actW ] 0 -> actW ;m :m InitNewWindow: setContRect: [self] set: self initfont true put: alive cls ;m :m PenIntoWind: \ Moves the GrafPort pen back into the window area if \ necessary, after the window has been resized. \ Actually at the moment we only worry about the vertical \ direction. @xy bottom min gotoxy ;m public \ Grow icon methods: :m SETCLIPGROWLEFT: put: clipgrowleft ;m \ Nov95 JRF :m SETCLIPGROWTOP: put: clipgrowtop ;m \ Nov95 JRF :m DRAWGROW: { \ l t r b -- } \ Nov95 JRF rev. get: growFlg 0EXIT get: clipgrowleft get: clipgrowtop OR NIF noClip @xy ^base call DrawGrowIcon gotoxy EXIT THEN getRect: self -> b -> r -> t -> l get: clipgrowleft IF r 15 - ELSE 0 THEN get: clipgrowtop IF b 15 - ELSE 0 THEN r b put: tempRect clip: tempRect @xy ^base call DrawGrowIcon gotoxy noClip ;m :m ERASEGROW: { \ l t r b -- } get: growFlg 0EXIT noClip getRect: self -> b -> r -> t -> l r 13 - b 13 - r b put: tempRect clear: tempRect ;m :m SETCONTRECT: \ Sets ContRect to the viewing area. Must be public since \ we late-bind to it, and it gets called from ObjInit anyway. get: portRect get: growFlg IF swap 15 - swap 15 - THEN put: contRect ?setfPrect: self ;m :m CLOSE: get: alive 0EXIT ^base call CloseWindow ^base actW = IF 0 -> actW THEN \ If this was the active window, it \ isn't any more clear: alive exec: close ;m :m RELEASE: close: [self] ;m \ Standard destructor - same as close. :m SET: \ Makes this wind the current GrafPort. It used \ to call setContRect: but there's really no need. set: super ?setfPrect: self ;m :m UPDATE: \ Generates an update event for the window with its \ entire port rectangle as the update region. pushPort set: self getRect: self put: tempRect update: tempRect popPort ;m :m NEW: { bndsRect tAddr tLen procID vis goAway \ s255 -- } \ Defines a new window on the heap with the specified features. \ Not resource based. get: alive ?EXIT \ Out if already alive bndsRect ->: contRect \ save rect locally ?disable_actW: self tAddr tLen str255 -> s255 ^base addr: contRect s255 vis 1 and procID inFront goAway 1 and 0 \ default is initially in front get: color? IF NewCWindow ELSE NewWindow THEN drop initNewWindow: self ;m :m GETNEW: \ ( resid -- ) Resource based new window. get: alive IF drop EXIT THEN \ Out if already alive ?disable_actW: self dup put: resid ^base inFront get: color? IF GetNewCWindow ELSE GetNewWindow THEN drop initNewWindow: self ;m :m GETVSRECT: \ ( l t r b -- l' t' r' b' ) \ Returns the default vert. scroll bar rect. get: portRect >vrect ;m :m GETHSRECT: \ ( l t r b -- l' t' r' b' ) \ Returns the default horiz. scroll bar rect. get: portRect >hrect ;m (* The DRAW: method is called, late-bound, whenever a window is updated. The implementation must begin with a BeginUpdate call and end with an EndUpdate call. We use the CallFirst/CallLast mechanism to ensure this, and also to draw the grow icon if this is a growable window. This means that any redefinition of DRAW: in a subclass should not call DRAW: super, since this would lead to BeginUpdate and EndUpdate being called more than once. So we define another method (DRAW): to do the actual work for DRAW:, and subclasses which need their own versions of DRAW: may call (DRAW): freely. *) private :m (DRAW): \ Does the main work for DRAW:. savePort @xy set: self \ Save port and pen posn, reset to this \ window exec: draw \ Call user draw routine restport gotoxy ;m \ Restore pen posn, restore original port :m SETUP_DRAW: get: fPrect \ Save fPrect as it might get changed ^base call BeginUpdate ;m :m WINDUP_DRAW: drawGrow: self ^base call EndUpdate put: fPrect ;m \ Restore fPrect callFirst setup_draw: callLast windup_draw: public :m DRAW: (draw): self ;m :m SELECT: \ Makes this the front window. ^base call SelectWindow ?setfPrect: self ;m (* The idle: method is called for the frontmost window, whenever a null event occurs. NULL-EVT is the normal word which sends idle:. In subclasses we redefine this method to do things like calling TEidle, which have to be done periodically. The Idle handler is also called, which allows a window-specific action to be taken. In the class Window itself, this is all we do. *) :m IDLE: exec: idle ;m :m SETIDLE: put: idle ;m :m ENABLE: \ Handles an activate event. set: self drawGrow: self exec: enact ;m :m DISABLE: \ Handles a deactivate event. eraseGrow: self exec: deact ;m :m ACTIONS: \ ( close enact draw cont 4 -- ) \ Sets up window event handler words. We require \ an xt count as this is normal for actions: methods. 4 ?#xts put: content put: draw put: enact put: close ;m :m SETACT: \ ( enact deact -- ) Sets just the activate/deactivate \ event handlers put: deact put: enact ;m :m SETDRAW: \ ( xt -- ) Sets the draw handler put: draw ;m :m SETCOLOR: \ ( b -- ) Sets the color? flag. put: color? ;m :m ACTIVE: \ ( -- b ) Is this window active ? 0 call FrontWindow ^base = ;m :m ALIVE: \ ( -- b ) Is this window alive? get: alive ;m :m DRAG: \ Handles a drag region click setLimits: self \ Omit in subclasses which need \ custom drag limits get: dragFlg 0exit ^base whrFEv addr: dragRect call DragWindow ;m private \ Some housekeeping routines for Size: and Zoom: :m ClrOldBars: getVSrect: self 16 + put: tempRect clear: tempRect update: tempRect \ Including the grow box getHSrect: self put: tempRect clear: tempRect update: temprect ;m :m FixNewBars: ClrOldBars: self \ Yes, the code's the same so far!! addr: portRect call ClipRect setContRect: [self] penIntoWind: self ;m public :m SIZE: \ ( w h -- ) Resizes window and accumulates update regions. pack ^base swap true makeint ClrOldBars: self call SizeWindow FixNewBars: self ;m :m SETSIZE: size: self ;m \ For naming consistency with Rects and \ Views. :m MOVE: \ ( x y -- ) Moves the window. pack ^base swap w 0 call MoveWindow ;m :m CENTER: { \ sw sh pw ph -- } \ Centers the window on the screen. \ Yeah, I know, here in Oz we spell this "centre", but we Ozzies \ are more flexible than the Yanks, so we'll magnanimously do it \ their way, not ours. screenbits -> sh -> sw 2drop size: portRect -> ph -> pw sw pw - 2/ sh ph - 2/ move: self ;m :m ZOOM: { part -- } word0 ^base whrFEv part makeint call TrackBox i->l IF getRect: self put: tempRect tempRect call EraseRect ^base part makeint word0 call ZoomWindow FixNewBars: self THEN ;m :m GROW: \ Handles a mouse-down in the grow box. get: growFlg IF setLimits: self \ Omit in subclasses which need \ custom grow limits 0 ^base whrFEv addr: growrect call GrowWindow ?dup IF unpack size: self ( draw: self ) penIntoWind: self THEN ELSE ^base call SelectWindow THEN update: self ;m :m CONTENT: \ Handles a content click. active: self IF exec: content ELSE select: self THEN ;m :m TITLE: \ ( addr len -- ) Sets the title of the window. str255 ^base swap call SetWTitle ;m :m NAME: ( addr len -- ) title: self ;m \ An alias for TITLE:. :m GETNAME: \ ( -- addr len ) Returns name of window. ^base buf255 call GetWTitle buf255 count ;m :m MAXX: \ ( -- x ) Returns the x coordinate value corresponding to \ the window being moved to the right of the screen. screenbits drop nip nip size: portRect drop - ;m :m MAXY: \ ( -- y ) screenbits nip nip nip size: portRect nip - ;m \ ================= :m KEY: \ ( c -- ) May be used in subclasses to do something with \ typed keys. Here, we just drop it. drop ;m :m SHOW: ^base call ShowWindow ;m :m HIDE: ^base call HideWindow ;m :m SETGROW: \ ( l t r b T | F -- ) Sets grow limits, if boolean is true. \ Note: in class Window itself, we IGNORE these grow limits and \ use a default value based on the size of the screen at the time \ the grow is actually done. dup put: growFlg if put: growrect then ;m :m SETDRAG: \ ( l t r b T | F -- ) Sets drag limits. \ Note: in class Window itself, we IGNORE these drag limits and \ use a default value based on the size of the screen at the time \ the drag is actually done. dup put: dragFlg if put: dragRect then ;m :m SETSCROLL: \ ( b -- ) put: scrollFlg ;m :m CLASSINIT: xts{ null null null null } actions: self ['] null dup put: idle put: deact true put: scrollFlg true put: dragFlg ;m :m MARKALIVE: \ A special method really intended just to allow us to \ mark fWind alive on startup. true put: alive ;m :m TEST: \ Fires up a test window. 100 100 300 200 put: tempRect screenbits true setGrow: self tempRect " Test" docWind true true new: self ;m ;class