(*-- AutoRev header do NOT edit! * * Program : GetFile.mod * Copyright : © 1993 * Author : Thilo Stöferle * Creation Date : 14-Apr-93 * Current version : 2.0 * Translator : M2Amiga V4.107d * * REVISION HISTORY * * Date Version Comment * --------- ------- ------------------------------------------ * 21-Aug-93 2.0 Own tags & instance, image scaling * 28-Jun-93 1.0 Total change: Implemented class myself * 14-Apr-93 0.0 Created module * *-- REV_END --*) IMPLEMENTATION MODULE GetFile; FROM SYSTEM IMPORT ADR,ADDRESS,LONGSET,TAG,CAST,REG,SETREG,ASSEMBLE; IMPORT i:IntuitionD, I:IntuitionL, g:GraphicsD, G:GraphicsL, M:GfxMacros, gt:GadToolsD, GT:GadToolsL, u:UtilityD, U:UtilityL, AL:AmigaLib, R; CONST GFDefFrontPen = 1; GFDefBackPen = 0; GFNumPolygon = 13; TYPE GFImgPolygon = ARRAY [0..GFNumPolygon-1] OF g.Point; GFInfoPtr = POINTER TO GFInfo; GFInfo = RECORD vi : ADDRESS; END; CONST GFOfsLeft = 4; GFOfsTop = 10; GFImage = GFImgPolygon{ g.Point{ x:0, y:-6 }, g.Point{ x:1, y:-6 }, g.Point{ x:1, y:0 }, g.Point{ x:11, y:0 }, g.Point{ x:11, y:-6 }, g.Point{ x:9, y:-8 }, g.Point{ x:6, y:-8 }, g.Point{ x:4, y:-6 }, g.Point{ x:2, y:-6 }, g.Point{ x:2, y:-5 }, g.Point{ x:5, y:-5 }, g.Point{ x:6, y:-4 }, g.Point{ x:10, y:-4 } }; (* switch off run time checks because we're running in Intuition's context *) (*$ NilChk := FALSE *) (*$ OverflowChk := FALSE *) (*$ CaseChk := FALSE *) (*$ ReturnChk := FALSE *) (*$ RangeChk := FALSE *) (*$ StackChk := FALSE *) (* for better performance... *) (*$ Volatile := FALSE *) (* ** Couldn't get AmigaLib.HookEntry working, it always crashes :-( ** This seems to be a bug in AmigaLib.HookEntry: ** ** M2Amiga procedures expect the stack contents to be ordered like this: ** [stack top] ** return address (generated by proc-caller) ** procedure arguments ** ** AmigaLib.HookEntry uses this order: ** [stack top] ** procedure arguments ** return address (generated by hook-caller) ** ** Because of this, the procedure jumps back to some random point, i.e. ** the value of an argument! This leads to quite 'colorful' trips to india... *) (* !!! this one requires ParDealloc:=FALSE in Hook.subEntry procedure !!! *) PROCEDURE HookEntry(hook{R.A0}:u.HookPtr; object{R.A2}:ADDRESS; message{R.A1}:ADDRESS ):ADDRESS; (*$ EntryExitCode := FALSE *) BEGIN ASSEMBLE( MOVE.L hook,-(SP) MOVE.L object,-(SP) MOVE.L message,-(SP) MOVE.L u.Hook.subEntry(hook),A0 JSR (A0) LEA.L 12(SP),SP RTS END); END HookEntry; (* still one not implemented... *) PROCEDURE InstData(cl:i.IClassPtr;obj:ADDRESS):ADDRESS; BEGIN RETURN(obj+LONGINT(cl^.instOffset)); END InstData; (* Our very own class dispatcher, built after Boopsi.s by JaBa *) PROCEDURE GetFileDispatcher(class:i.IClassPtr;object:i.ImagePtr;message:i.Msg):ADDRESS; VAR SetMsg : i.OpSetPtr; DrawMsg : i.ImpDrawPtr; MyVI : ADDRESS; MyWidth,MyHeight : INTEGER; MyInstance : GFInfoPtr; MyVectors : GFImgPolygon; Count : INTEGER; UsedPen : CARDINAL; TagBuffer : ARRAY [0..4] OF LONGINT; PROCEDURE RealX(x:INTEGER):INTEGER; BEGIN RETURN((x*MyWidth) DIV DefaultWidth); END RealX; PROCEDURE RealY(y:INTEGER):INTEGER; BEGIN RETURN((y*MyHeight) DIV DefaultHeight); END RealY; (*$ SaveA4 := TRUE *) (*$ ParDealloc := FALSE *) (* !!! IMPORTANT !!! *) BEGIN SETREG(R.A4,class^.dispatcher.data); CASE message^.methodID OF | i.omNEW: SetMsg := CAST(i.OpSetPtr,message); MyVI := U.GetTagData(u.Tag(gfVisualInfo),0,SetMsg^.attrList); MyWidth := U.GetTagData(u.Tag(gfWidth),DefaultWidth,SetMsg^.attrList); MyHeight := U.GetTagData(u.Tag(gfHeight),DefaultHeight,SetMsg^.attrList); IF (MyVI # NIL) THEN object := AL.DoSuperMethodA(class,object,message); IF (object # NIL) THEN object^.width := MyWidth; object^.height := MyHeight; MyInstance := InstData(class,object); MyInstance^.vi := MyVI; RETURN(object); END; END; RETURN(NIL); | i.imDraw: DrawMsg := CAST(i.ImpDrawPtr,message); MyWidth := object^.width; MyHeight := object^.height; MyInstance := InstData(class,object); MyVI := MyInstance^.vi; (* calculate real screen coordinates *) FOR Count := 0 TO GFNumPolygon-1 BY 1 DO MyVectors[Count].x := RealX(GFImage[Count].x+GFOfsLeft) + DrawMsg^.offset.x; MyVectors[Count].y := RealY(GFImage[Count].y+GFOfsTop) + DrawMsg^.offset.y; END; G.SetDrMd(DrawMsg^.rPort,g.jam2); IF (DrawMsg^.state = i.idsSelected) THEN IF (DrawMsg^.drInfo # NIL) THEN UsedPen := DrawMsg^.drInfo^.pens^[i.fillPen]; ELSE UsedPen := GFDefFrontPen; (* FGPen *) END; ELSE IF (DrawMsg^.drInfo # NIL) THEN UsedPen := DrawMsg^.drInfo^.pens^[i.backGroundPen]; ELSE UsedPen := GFDefBackPen; (* BGPen *) END; END; G.SetAPen(DrawMsg^.rPort,UsedPen); M.SetAfPen(DrawMsg^.rPort,NIL,0); G.RectFill(DrawMsg^.rPort,DrawMsg^.offset.x,DrawMsg^.offset.y, DrawMsg^.offset.x+MyWidth-1,DrawMsg^.offset.y+MyHeight-1); IF (DrawMsg^.state = i.idsSelected) THEN GT.DrawBevelBoxA(DrawMsg^.rPort,DrawMsg^.offset.x,DrawMsg^.offset.y, MyWidth,MyHeight,TAG(TagBuffer, gt.gtVisualInfo,MyVI, gt.gtbbRecessed,TRUE, u.tagDone)); ELSE GT.DrawBevelBoxA(DrawMsg^.rPort,DrawMsg^.offset.x,DrawMsg^.offset.y, MyWidth,MyHeight,TAG(TagBuffer, gt.gtVisualInfo,MyVI, u.tagDone)); END; IF (DrawMsg^.state = i.idsSelected) THEN IF (DrawMsg^.drInfo # NIL) THEN UsedPen := DrawMsg^.drInfo^.pens^[i.fillTextPen]; ELSE UsedPen := GFDefBackPen; (* BGPen *) END; ELSE IF (DrawMsg^.drInfo # NIL) THEN UsedPen := DrawMsg^.drInfo^.pens^[i.textPen]; ELSE UsedPen := GFDefFrontPen; (* FGPen *) END; END; G.SetAPen(DrawMsg^.rPort,UsedPen); G.Move(DrawMsg^.rPort, DrawMsg^.offset.x+RealX(GFOfsLeft), DrawMsg^.offset.y+RealY(GFOfsTop)); G.PolyDraw(DrawMsg^.rPort,GFNumPolygon,ADR(MyVectors)); RETURN(1); ELSE RETURN(AL.DoSuperMethodA(class,object,message)); END; END GetFileDispatcher; (*$ POP NilChk *) (*$ POP OverflowChk *) (*$ POP CaseChk *) (*$ POP ReturnChk *) (*$ POP RangeChk *) (*$ POP StackChk *) PROCEDURE InitGetFile():i.IClassPtr; VAR GFClass : i.IClassPtr; BEGIN GFClass := I.MakeClass(NIL,ADR(i.imageClass),NIL,SIZE(GFInfo),LONGSET{}); IF (GFClass # NIL) THEN GFClass^.dispatcher.data := REG(R.A4); GFClass^.dispatcher.entry := HookEntry; GFClass^.dispatcher.subEntry := ADR(GetFileDispatcher); END; RETURN(GFClass); END InitGetFile; PROCEDURE FreeGetFile(); BEGIN IF (GetFileClass # NIL) THEN IF I.FreeClass(GetFileClass) THEN GetFileClass := NIL; END; END; END FreeGetFile; BEGIN GetFileClass := InitGetFile(); CLOSE FreeGetFile(); END GetFile.