!! File: LinearPhasePortraits.bu !! May 26, 2003 Hubert Hohn - revised classification PUBLIC PCFlag,Mac5Flag,M68KFlag,UnixFlag,xmax,ymax PUBLIC toolLft,toolRgt,toolBas,toolTop,toolhdr,toolHgt,toolWid ! tool boundaries PUBLIC winLft,winRgt,winBas,winTop,winHgt,winWid ! window PUBLIC workLft,workRgt,workBas,workTop,workMidx ! work area PUBLIC backclr,black,drkgry,drkmid,midgry,litmid,litgry,white PUBLIC red,yellow,green,cyan,blue,magenta,pink,colorscheme PUBLIC planeclr,gridclr,rimclr,axisclr,axislabelclr,titleclr,rightsclr PUBLIC numberlineclr,slotdrkclr,slotlgtclr,slideclr PUBLIC largefonts, title$, SLUmode LET toolHgt= 560 LET toolWid= 780 LET window$= "D'Arbeloff Interactive Math Project" LET colorscheme= 0 LET title$= "Linear Phase Portraits" SUB ThisProgram CALL ParameterPlane CLEAR END SUB !! --------------------------------------------------------- !! ------ Start TB4 Mac Header and Subs ------ !LET M68KFlag = 1 !LIBRARY "MacTools*", "HHLib.trc" !ASK PIXELS winWid,winHgt !LET winLft= 0 !LET winTop= 0 !LET winRgt= winWid-1 !LET winBas= winHgt-1 !SET WINDOW 0,winRgt,winBas,0 !CALL Palette !CLEAR ! !CALL ToolPanel !CALL ThisProgram ! !END !EXTERNAL ! !MODULE Mac4Parts ! SUB SetTextFont(font,size,style$) ! CALL MacTextFont(font) ! CALL MacTextSize(size) ! CALL MacTextFace(style$) ! END SUB ! ! SUB StringWidth(sw$,sl) ! DECLARE DEF MacStringWidth ! LET sl= MacStringWidth(sw$) ! END SUB ! ! SUB SetLineWeight(wgt) ! CALL MacPenSize(wgt,wgt) ! END SUB ! ! SUB BoxDisk(Lft,Rgt,Bas,Top) ! CALL MacPaintOval(Lft,Rgt,Bas,Top) ! END SUB !END MODULE !! --- End TB4 Mac Header and Subs --- !!--------------------------------------------------------- !!--- Start TB5 Cross-Platform header and subs --- LIBRARY "c:\TB Gold 51a\TBLibs\TrueCtrl.trc" ! windows LIBRARY "c:\TB Gold 51a\TBLibs\HHLib.trc" ! !LIBRARY ":TBLibs:TrueCtrl.trc" ! macintosh !LIBRARY "HHLib.trc" ! PUBLIC WinID DECLARE PUBLIC OBJM_SET,OBJM_SYSINFO LET winHgt= toolHgt LET winWid= toolWid DIM values(1) CALL TC_Init CALL Object(OBJM_SYSINFO,WinID,"MACHINE",system$,values()) IF system$="MAC" then LET Mac5Flag= 1 ELSE IF system$="WIN32" then LET PCFlag = 1 END IF CALL TC_SetUnitsToPixels ! 5.1 and up needs this CALL TC_GetScreenSize(scrnLft,scrnRgt,scrnBas,scrnTop) LET winLft= int((scrnRgt-scrnLft-winWid)/2) LET winRgt= winLft+winWid-1 LET winTop= int((scrnBas-scrnTop-winHgt)/2) + 10 LET winBas= winTop+winHgt-1 CALL TC_Win_Create (WinID,"TITLE",winLft,winRgt,winBas,winTop) LET values(1)= 2 CALL Object(OBJM_SET, WinID, "TYPE", "", values()) IF PCFlag=1 then ! kill dithering LET values(1)= 1 CALL Object(OBJM_SET, WinID, "SOLID MIX", "", values()) END IF LET values(1)= 0 CALL TC_SetRect(WinID,winLft,winRgt,winBas,winTop) CALL TC_Win_SetTitle(WinID,window$) CALL TC_Show(WinID) SET MODE "COLORSTANDARD" ASK PIXELS winWid,winHgt ! must follow set mode LET winLft= 0 LET winTop= 0 LET winRgt= winWid-1 LET winBas= winHgt-1 SET WINDOW 0,winRgt,winBas,0 CALL Palette IF PCFlag=1 then LET values(1)= 0 ! now force solid colors CALL Object(OBJM_SET, WinID, "SOLID MIX", "", values()) CALL TC_Win_RealizePalette(WinID) ! some PCs need this CALL TC_Win_SetFont(WinID,"arial",9,"plain") CALL StringWidth("0",sw) IF sw>7 then LET largefonts=1 else LET largefonts=0 END IF CALL TC_Win_Switch(WinID) CALL ToolPanel CALL ThisProgram CALL SetTextFont(1,12,"bold") ! now shut down and clean up LET quit$= "click the mouse or press a key to close..." CALL PlotTextCJ(workmidx,(workBas+workTop)/2,quit$,yellow) CALL TC_CleanUp END EXTERNAL MODULE TB5Parts SUB StringWidth(sw$,sl) DECLARE PUBLIC WinID LET sl= StrWidth(WinID,sw$) END SUB SUB SetLineWeight(wgt) DECLARE PUBLIC OBJM_SET DECLARE PUBLIC WinID DIM values(1) LET values(1)= wgt CALL Object(OBJM_SET,WinID, "WIDTH", "", values()) END SUB SUB SetTextFont(font,size,style$) DECLARE PUBLIC WinID,Mac5Flag,PCFlag,largefonts IF Mac5Flag=1 then SELECT CASE font CASE 4 LET font$= "Courier" CASE 16 LET font$= "Times" CASE else LET font$= "Geneva" END SELECT ELSE IF PCFlag=1 then IF largefonts=1 then IF size<12 then LET size= 6 ELSE IF size=14 then LET size= 10 ELSE IF size=18 then LET size= 12 ELSE IF size=24 then LET size= 14 ELSE IF size=12 then LET size= 8 ELSE LET size= round(72/96 * size * .8) END IF ELSE IF size<12 then LET size= 7 ELSE IF size=14 then LET size= 12 ELSE IF size=12 then LET size= 9 ELSE IF size=18 then LET size= 14 ELSE IF size=24 then LET size= 18 ELSE LET size= round(72/96 * size) END IF END IF SELECT CASE font CASE 4 LET font$= "Courier New" CASE 16 LET font$= "Times New Roman" CASE else LET font$= "Verdana" END SELECT END IF IF style$= "normal" then LET style$= "plain" CALL TC_Win_SetFont(WinID,font$,size,style$) END SUB SUB BoxDisk(Lft,Rgt,Bas,Top) BOX DISK Lft,Rgt,Bas,Top END SUB END MODULE ! --- End TB5 Cross-platform header and subs --- !! --------------------------------------------------------- !! --- Start Unix Header and Subs --- !LIBRARY "HHLib.trc" !LET UnixFlag= 1 !ASK PIXELS winWid,winHgt !LET winLft= 0 !LET winTop= 0 !LET winRgt= winWid-1 !LET winBas= winHgt-1 !SET WINDOW 0,winRgt,winBas,0 !CALL Palette ! !CALL ToolPanel !CALL ThisProgram ! !END !EXTERNAL ! !MODULE UnixParts ! SHARE CharWidth ! ! SUB SetTextFont(font,size,style$) ! LET font$= "-adobe-courier-" ! IF style$= "normal" then ! LET style$= "medium-r-normal--" ! ELSE ! LET style$= "bold-r-normal--" ! END IF ! IF size=9 then ! LET size$= str$(10) ! ELSE ! LET size$= str$(size) ! END IF ! LET test= SetFont(font$&style$&size$&"*") ! ! IF size=9 then ! LET CharWidth= 6 ! ELSE IF size=12 then ! numeric output - axis labels ! LET CharWidth= 7 ! ELSE IF size=14 then ! rare ! LET CharWidth= 8 ! ELSE IF size=18 then ! rare ! LET CharWidth= 10 ! END IF ! END SUB ! ! SUB StringWidth(sw$,sl) ! string width in pixels ! ! LET sl= StrWidth(sw$) ! LET chars= len(sw$) ! LET sl = chars*CharWidth ! END SUB ! ! SUB SetLineWeight(wgt) ! ! CALL PenSize(wgt,wgt) ! END SUB ! ! SUB BoxDisk(Lft,Rgt,Bas,Top) ! CALL Fill_Circle(Lft,Rgt,Bas,Top) ! END SUB !END MODULE !! ------ End of TB Unix Header and Subs ------ !! ----------------------------------------------------------- ! --- End TB5 header and subs --- SUB ParameterPlane DECLARE PUBLIC black,drkgry,drkmid,midgry,litmid,litgry,white DECLARE PUBLIC red,yellow,green,cyan,blue,magenta,colorscheme DECLARE PUBLIC planeclr,gridclr,rimclr,axisclr,axislabelclr,slideclr DECLARE PUBLIC workLft,workRgt,workBas,workTop,workMidx DECLARE PUBLIC true,false DECLARE DEF quitWithin, infoWithin ! --- help screen array --- DIM info$(1:7) MAT READ info$ DATA "Linear Phase Portraits" DATA "" DATA "Purpose: LinearPhasePortraits lets you view phase portraits of linear systems. You can choose the linear system using the sliders or by selecting a point in the trace-determinant plane." DATA "" DATA "To Begin: Select a point in the xy-plane to see the solution curve corresponding to this initial condition." DATA "" DATA "Further Options: Clicking on a point in the trace-determinant plane selects a matrix with that trace and determinant. Its phase portrait is then displayed by clicking in the xy-plane. The eigenvalues are displayed as blue dots in the small plane in the lower left." ! --- color LET b0= 0 LET b1= .2 LET b2= .4 LET b3= .6 LET b4= .8 LET b5= 1 SET COLOR MIX(red) b5,b3,b1 ! red SET COLOR MIX(blue) b2,b3,b5 ! blue ! ---------- Utility functions --- DECLARE DEF clamp,roundn,e DEF notanum= 987656789 ! --- functions DEF dxdt(x,y)= a*x + b*y DEF dydt(x,y)= c*x + d*y SUB Complex(trace,dterm,dscrm,cmplx) LET dscrm= trace*trace - 4*dterm ! find discriminant IF dscrm<0 then LET cmplx= 1 else LET cmplx= 0 ! complex? END SUB SUB LinearParams(a,b,c,d,trace,dterm,dscrm,cmplx) LET trace= a+d LET dterm= a*d - b*c LET dscrm= trace*trace - 4*dterm ! find discriminant IF dscrm<0 then LET cmplx= 1 else LET cmplx= 0 ! complex? END SUB ! ---------- Graphing plane parameters and methods ---------- ! --- w1 data t,x --- DECLARE PUBLIC w1Lft, w1Rgt, w1Bas, w1Top, w1Midx, w1Midy DECLARE PUBLIC w1fLft, w1fRgt, w1fBas, w1fTop, w1x0, w1y0 DECLARE PUBLIC w1xFirst, w1xSTik, w1xLTik, w1xLabel, w1xGridstep DECLARE PUBLIC w1yFirst, w1ySTik, w1yLTik, w1yLabel, w1yGridstep DECLARE PUBLIC w1xPiFlag, w1xMult, w1yPiFlag, w1yMult DECLARE PUBLIC w1wWid, w1fWid, w1wHgt, w1fHgt, w1Aspect LET w1Flag = 1 ! pixel window visibility LET w1xPiFlag= 0 ! pi switch for x axis LET w1xMult = 1 LET w1yPiFlag= 0 ! pi switch for y axis LET w1yMult = 1 LET w1Lft = workLft+70 ! pixel bounds LET w1Rgt = w1Lft+200 ! for 6 LET w1Top = workTop+40 LET w1Bas = w1Top+200 LET w1size= 4 LET w1fLft= -w1size ! function bounds LET w1fRgt= w1size LET w1fBas= -w1size LET w1fTop= w1size LET w1Xax$= "tr A" ! axis labels LET w1Yax$= "det A" LET w1xGridstep= 0 ! horizontal grid intervals LET w1yGridstep= 0 ! vertical grid intervals LET w1xSTik = 1/2 ! horizontal axis Tik marks LET w1xLTik = 1 LET w1xLabel= 1 LET w1xFirst= w1fLft LET w1ySTik = 1/2 ! vertical axis Tik marks LET w1yLTik = 1 LET w1yLabel= 1 LET w1yFirst= w1fBas ! --- Plane 1 methods --- DECLARE DEF w1fncx,w1fncy,w1wndx,w1wndy ! window/function transforms DECLARE DEF w1Within, w1wWithin CALL w1Variables SUB w1Init LET aspect= (w1wwid/w1fwid)/(w1whgt/w1fhgt) CALL w1DrawPlane(1,1,1) ! grid, axes, zeroaxes CALL SetTextFont(1,12,"bold") CALL PlotTextLJ(w1Rgt+8,w1y0+3,w1Xax$,axislabelclr) ! axis labels CALL PlotTextCJ(w1x0,w1Top-10,w1Yax$,axislabelclr) CALL DrawTDPlane CALL w1KeepGridLayer CALL w1KeepGraphLayer END SUB ! ------------------------------------------ ! --- w2 data: phase line --- DECLARE PUBLIC w2Lft,w2Rgt,w2Bas,w2Top,w2Midx,w2Midy DECLARE PUBLIC w2fLft,w2fRgt,w2fBas,w2fTop,w2x0,w2y0 DECLARE PUBLIC w2xFirst, w2xSTik, w2xLTik, w2xLabel, w2xGridstep DECLARE PUBLIC w2yFirst, w2ySTik, w2yLTik, w2yLabel, w2yGridstep DECLARE PUBLIC w2xPiFlag, w2xMult, w2yPiFlag, w2yMult DECLARE PUBLIC w2wWid, w2fWid, w2wHgt, w2fHgt, w2Aspect LET w2Flag = 1 LET w2xPiFlag= 0 LET w2xMult = 1 LET w2yPiFlag= 0 LET w2yMult = 1 LET w2Lft = workRgt-65-300 ! pixel bounds LET w2Rgt = w2Lft + 300 LET w2Top = w1Top LET w2Bas = w2Top + 300 LET w2fLft= -3 ! function bounds * pi LET w2fRgt= 3 LET w2fBas= -3 LET w2fTop= 3 LET w2xGridstep= 0 ! horizontal grid intervals LET w2yGridstep= 0 ! vertical grid intervals LET w2xAx$= "x" ! axis labels LET w2yAx$= "y" LET w2xSTik = 1/2 ! horizontal axis Tik marks LET w2xLTik = 1 LET w2xLabel= 1 LET w2xFirst= w2fLft LET w2ySTik = 1/2 ! vertical axis Tik marks LET w2yLTik = 1 LET w2yLabel= 1 LET w2yFirst= w2fBas ! --- plane 2 methods --- DECLARE DEF w2fncx, w2fncy, w2wndx, w2wndy ! window/function transforms DECLARE DEF w2Within, w2wWithin CALL w2Variables SUB w2Init CALL w2DrawPlane(1,1,1) ! grid, axes, zeroaxes CALL SetTextFont(1,12,"bold") CALL PlotTextLJ(w2Rgt+8,w2y0+3,w2xAx$,axislabelclr) ! axis labels CALL PlotTextCJ(w2x0,w2Top-10,w2yAx$,axislabelclr) CALL w2KeepGridLayer CALL w2KeepGraphLayer END SUB ! --- plane 4 data: eigenvalue plane --- DECLARE PUBLIC w4Lft, w4Rgt, w4Bas, w4Top, w4Midx, w4Midy DECLARE PUBLIC w4fLft, w4fRgt, w4fBas, w4fTop, w4x0, w4y0 DECLARE PUBLIC w4xFirst, w4xSTik, w4xLTik, w4xLabel, w4xGridstep DECLARE PUBLIC w4yFirst, w4ySTik, w4yLTik, w4yLabel, w4yGridstep DECLARE PUBLIC w4xPiFlag, w4xMult, w4yPiFlag, w4yMult DECLARE PUBLIC w4wWid, w4fWid, w4wHgt, w4fHgt, w4Aspect LET w4Flag = 1 ! pixel window visibility LET w4xPiFlag= 0 ! pi switch for x axis LET w4xMult = 1 LET w4yPiFlag= 0 ! pi switch for y axis LET w4yMult = 1 LET w4Lft = w1Lft ! pixel bounds LET w4Rgt = w4Lft + 80 LET w4Top = workBas - 110 LET w4Bas = w4Top + 80 LET w4fLft = -4 ! function bounds LET w4fRgt = 4 LET w4fBas = -4 LET w4fTop = 4 LET w4xAx$ = "Re" ! axis labels LET w4yAx$ = "Im" LET w4xGridstep= 0 ! grid line intervals LET w4yGridstep= 0 LET w4xSTik = 1 ! axis Tik marks LET w4xLTik = 2 LET w4xLabel= 2 LET w4xFirst= w4fLft LET w4ySTik = 1 LET w4yLTik = 2 LET w4yLabel= 2 LET w4yFirst= w4fBas ! --- plane 4 methods --- DECLARE DEF w4fncx,w4fncy,w4wndx,w4wndy ! window/function transforms CALL w4Variables SUB w4Clear BOX CLEAR w4Lft-25,w4Rgt+25,w4Bas+25,w4Top-25 END SUB SUB w4Init CALL w4DrawPlane(1,1,1) ! grid, axes, zeroaxes CALL SetTextFont(1,12,"bold") CALL PlotTextLJ(w4Rgt+8,w4y0+3,w4xAx$,axislabelclr) ! axis labels CALL PlotTextCJ(w4x0,w4Top-10,w4yAx$,axislabelclr) CALL w4KeepGridLayer CALL w4KeepGraphLayer END SUB ! ------ matrix ------ LET lnspc= 15 LET mTop = w1Bas + 80 LET mBas = mTop + 40 LET mLft = w1Lft LET mRgt = mLft + 115 LET mtxt0= mTop + 14 LET mtxt1= mTop + 33 LET mcol1= mLft + 10 LET mcol2= mcol1 + 50 LET mmidx= int((mLft+mRgt)/2) SUB DrawMatrix LET midm= int((mTop+mBas)/2) CALL PlotTextLJ(mLft-20,midm+3,"A=",litgry) SET COLOR litmid ! matrix brackets PLOT mLft+5,mTop ; mLft,mTop ; mLft,mBas ; mLft+5,mBas PLOT mLft+5,mTop+1; mLft+1,mTop+1; mLft+1,mBas-1; mLft+5,mBas-1 PLOT mRgt-5,mTop ; mRgt,mTop ; mRgt,mBas ; mRgt-5,mBas PLOT mRgt-5,mTop+1; mRgt-1,mTop+1; mRgt-1,mBas-1; mRgt-5,mBas-1 END SUB SUB ClearMatrix BOX CLEAR mLft-30,mRgt+10,mBas+10,mTop-10 END SUB SUB ShowMatrixValues CALL SetTextFont(1,12,"bold") LET matclr= litgry CALL ClearMatrixValues CALL PlotTextLJ(mcol1,mtxt0,using$("--%.##",a),matclr) CALL PlotTextLJ(mcol2,mtxt0,using$("--%.##",b),matclr) CALL PlotTextLJ(mcol1,mtxt1,using$("--%.##",c),matclr) CALL PlotTextLJ(mcol2,mtxt1,using$("--%.##",d),matclr) END SUB SUB ClearMatrixValues BOX CLEAR mLft+3,mRgt-3,mtxt0+3,mtxt0-10 ! upper row BOX CLEAR mLft+3,mRgt-3,mtxt1+3,mtxt1-10 ! lower row END SUB SUB MatAReset(ma) CALL SetTextFont(1,12,"bold") BOX CLEAR mcol1-2,mcol2-5,mtxt0+5,mtxt0-10 CALL PlotTextLJ(mcol1,mtxt0,using$("--%.##",ma),matclr) END SUB SUB MatBReset(mb) CALL SetTextFont(1,12,"bold") BOX CLEAR mcol2-2,mRgt-5,mtxt0+5,mtxt0-10 CALL PlotTextLJ(mcol2,mtxt0,using$("--%.##",mb),matclr) END SUB SUB MatCReset(mc) CALL SetTextFont(1,12,"bold") BOX CLEAR mcol1-2,mcol2-5,mtxt1+5,mtxt1-10 CALL PlotTextLJ(mcol1,mtxt1,using$("--%.##",mc),matclr) END SUB SUB MatDReset(md) CALL SetTextFont(1,12,"bold") BOX CLEAR mcol2-2,mRgt-5,mtxt1+5,mtxt1-10 CALL PlotTextLJ(mcol2,mtxt1,using$("--%.##",md),matclr) END SUB SUB MatResetAll(a,b,c,d) LET ma= a LET mb= b LET mc= c LET md= d CALL MatAReset(a) CALL MatBReset(b) CALL MatCReset(c) CALL MatDReset(d) END SUB ! --- matrix sliders --- LET matslidebound= 4 LET matslidewid = 80 ! --- h1 slider --- DECLARE PUBLIC h1axis,h1wLft,h1wRgt,h1wBas,h1wTop,h1fLft,h1fRgt DECLARE PUBLIC h1name$,h1form$,h1clr,h1First,h1STik,h1LTik,h1Label DECLARE PUBLIC h1PiAxis,h1Mult,h1fMin,h1fMax DECLARE DEF h1Fncx, h1Within ! window/function transforms LET h1PiAxis= 0 LET h1Mult = 1 LET h1clr = slideclr LET h1name$ = "a" LET h1form$ = "-%.#" LET h1Places= 1 LET h1axis = w2Bas + 115 LET h1wLft = w2Lft LET h1wRgt = h1wLft+matslidewid LET h1fLft = -matslidebound LET h1fRgt = matslidebound LET h1STik = 1 ! short tick marks LET h1LTik = matslidebound ! long tick marks LET h1Label = matslidebound ! labels LET h1First = h1fLft ! first tick mark LET h1Click = 1/2 CALL h1SliderVariables ! --- h2 Slider --- DECLARE PUBLIC h2axis,h2wLft,h2wRgt,h2wBas,h2wTop,h2fLft,h2fRgt DECLARE PUBLIC h2name$,h2form$,h2clr,h2First,h2STik,h2LTik,h2Label DECLARE PUBLIC h2PiAxis,h2Mult,h2fMin,h2fMax DECLARE DEF h2Fncx, h2Within ! window/function transforms LET h2PiAxis= 0 LET h2Mult = 1 LET h2clr = slideclr LET h2name$ = "b" LET h2form$ = "-%.#" LET h2Places= 1 LET h2axis = h1axis LET h2wLft = h1wRgt + 100 LET h2wRgt = h2wLft + matslidewid LET h2fLft = -matslidebound LET h2fRgt = matslidebound LET h2STik = 1 LET h2LTik = matslidebound LET h2Label = matslidebound LET h2First = h2fLft LET h2Click = 1/2 CALL h2SliderVariables ! --- h3 slider --- DECLARE PUBLIC h3axis,h3wLft,h3wRgt,h3wBas,h3wTop,h3fLft,h3fRgt DECLARE PUBLIC h3name$,h3form$,h3clr,h3First,h3STik,h3LTik,h3Label DECLARE PUBLIC h3PiAxis,h3Mult,h3fMin,h3fMax DECLARE DEF h3Fncx, h3Within ! window/function transforms LET h3PiAxis= 0 LET h3Mult = 1 LET h3clr = slideclr LET h3name$ = "c" LET h3form$ = "-%.#" LET h3Places= 1 LET h3axis = h1axis + 45 LET h3wLft = h1wLft LET h3wRgt = h1wRgt LET h3fLft = -matslidebound LET h3fRgt = matslidebound LET h3STik = 1 LET h3LTik = matslidebound LET h3Label = matslidebound LET h3First = h3fLft LET h3Click = 1/2 CALL h3SliderVariables ! --- h4 slider --- DECLARE PUBLIC h4axis,h4wLft,h4wRgt,h4wBas,h4wTop,h4fLft,h4fRgt DECLARE PUBLIC h4name$,h4form$,h4clr,h4First,h4STik,h4LTik,h4Label DECLARE PUBLIC h4PiAxis,h4Mult,h4fMin,h4fMax DECLARE DEF h4Fncx, h4Within ! window/function transforms LET h4PiAxis= 0 LET h4Mult = 1 LET h4clr = slideclr LET h4name$ = "d" LET h4form$ = "-%.#" LET h4Places= 1 LET h4axis = h3axis LET h4wLft = h2wLft LET h4wRgt = h2wRgt LET h4fLft = -matslidebound LET h4fRgt = matslidebound LET h4STik = 1 LET h4LTik = matslidebound LET h4Label = matslidebound LET h4First = h4fLft LET h4Click = 1/2 CALL h4SliderVariables ! -------- text locations ------ ! ----- t1 - w2 initial values ----- LET t1Lft = w2Midx + 60 LET t1Rgt = w2Rgt LET t1Bas1 = w2Bas + 39 LET t1Bas2 = t1Bas1 + 25 LET t1Top = t1Bas1 - 15 LET t1Bas = t1Bas2 + 5 LET t1Label1$= "x(0) = " LET t1Label2$= "y(0) = " CALL StringWidth(t1Label1$,sw) LET t1Eqx = t1Lft + sw LET t1clr = litgry SUB t1Init CALL PlotTextRJ(t1Eqx,t1Bas1,t1Label1$,t1clr) CALL PlotTextRJ(t1Eqx,t1Bas2,t1Label2$,t1clr) END SUB SUB t1Clear BOX CLEAR t1Lft-2,t1Rgt,t1Bas,t1Top END SUB SUB t1SetValues(x0,y0) CALL t1ClearValues LET x$= using$("-%.##",x0) CALL PlotTextRJ(t1Rgt,t1Bas1,x$,t1clr) LET y$= using$("-%.##",y0) CALL PlotTextRJ(t1Rgt,t1Bas2,y$,t1clr) END SUB SUB t1ClearValues BOX CLEAR t1Eqx,t1Rgt+10,t1Bas,t1Top END SUB ! ----- t2 - classification name ----- LET t2Lft = w2Lft LET t2Rgt = t1Lft-2 LET t2BasLn= t1Bas2 LET t2Top = t2BasLn -12 LET t2Bas = t2BasLn +5 SUB t2SetName(name$) CALL t2Clear CALL SuperSubScriptLJ(t2Lft,t2BasLn,name$,tclr) END SUB SUB t2Clear BOX CLEAR t2Lft-2,t2Rgt,t2Bas,t2Top END SUB ! ----- t3 - trace and det ----- LET t3Lft1 = w1Lft LET t3Lft2 = t3Lft1 LET t3Rgt = w2Lft - 20 LET t3Bas1 = w1Bas+40 LET t3Bas2 = t3Bas1+20 LET t3Top = t3Bas1 - 12 LET t3Bas = t3Bas2 + 5 LET t3eqx = t3Lft1+60 CALL StringWidth(" -44.44",sw) LET t3txtRgt= t3eqx + sw LET t3Clr = litgry SUB t3Init CALL t3Clear CALL SetTextFont( 1,12,"bold") CALL PlotTextRJ(t3eqx,t3Bas1,"tr A = ",t3Clr) CALL PlotTextRJ(t3eqx,t3Bas2,"det A = ",t3Clr) CALL t3SetValue END SUB SUB t3Clear BOX CLEAR t3Lft1-2,t3Rgt,t3Bas,t3Top END SUB SUB t3SetValue CALL t3ClearValue CALL SetTextFont( 1,12,"bold") CALL PlotTextRJ(t3txtRgt,t3Bas1,using$("-%.##",trace),t3Clr) CALL PlotTextRJ(t3txtRgt,t3Bas2,using$("--%.##",dterm),t3Clr) END SUB SUB t3ClearValue BOX CLEAR t3eqx-2,t3Rgt,t3Bas,t3Top END SUB ! ----- t4 - eigenvalues ----- LET t4Lft = w4Rgt + 40 LET t4Rgt = t4Lft + 155 LET t4Bas1= w4Midy - 5 LET t4Bas2= t4Bas1 + 18 LET t4Bas = t4Bas2 + 5 LET t4Top = t4Bas1 - 12 LET t4Eqx = t4Lft + 44 LET t4Clr = litgry SUB t4Init CALL DrawLam(t4Lft+14,t4Bas1,t4Clr) CALL DrawLam(t4Lft+14,t4Bas2,t4Clr) CALL SetTextFont(1,9,"bold") CALL PlotTextLJ(t4Lft+23,t4Bas1+4,"1",t4Clr) CALL PlotTextLJ(t4Lft+23,t4Bas2+4,"2",t4Clr) CALL SetTextFont(1,12,"bold") CALL PlotTextLJ(t4Lft+32,t4Bas1,"=",t4Clr) CALL PlotTextLJ(t4Lft+32,t4Bas2,"=",t4Clr) CALL t4SetValues END SUB SUB t4SetValues CALL FindLamdas CALL t4ClearValues CALL SetTextFont(1,12,"bold") CALL PlotTextLJ(t4Eqx,t4Bas1,l1$,t4Clr) CALL PlotTextLJ(t4Eqx,t4Bas2,l2$,t4Clr) END SUB SUB t4Clear BOX CLEAR t4Lft-2,t4Rgt,t4Bas,t4Top END SUB SUB t4ClearValues BOX CLEAR t4Eqx,t4Rgt,t4Bas,t4Top END SUB ! --- SUB SetFunctions ! CALL SetTextFont(1,12,"bold") ! CALL PlotTextLJ(wLft2+50,pTop+16,"x' = ax + by",2) ! CALL PlotTextLJ(wLft2+50,pTop+32,"y' = cx + dy",2) END SUB ! --- buttons -- LET bhgt= 19 LET cTop= w2Bas + 25 LET cBas= cTop + bhgt LET cLft= w2Lft LET cRgt= cLft + 50 LET evbTop= workBas - 20 LET evbBas= evbTop + bhgt LET evbLft= w4Rgt + 55 LET evbRgt= evbLft + 95 SUB Buttons CALL SetTextFont(1,12,"bold") CALL DrawButton(cLft,cRgt,cBas,cTop,6,"clear") CALL DrawButton(evbLft,evbRgt,evbBas,evbTop,6,"eigenvalues") END SUB ! ----- default parameters ----- IF M68kFlag=1 then LET tstep= 1/64 ELSE LET tstep= 1/32 END IF LET ma,a,oldma = 2 LET mb,b,oldmb = 1 LET mc,c,oldmc = 1 LET md,d,oldmd = -1 ! ----- initialize ----- CALL LinearParams(a,b,c,d,trace,dterm,dscrm,cmplx) CALL InitScreen SUB InitScreen BOX CLEAR workLft,workRgt,workBas,workTop CALL w1Init CALL w2Init IF lamflag=1 then CALL w4Init CALL t4Init END IF CALL DrawMatrix CALL h1DrawSlider(h1name$,a) CALL h2DrawSlider(h2name$,b) CALL h3DrawSlider(h3name$,c) CALL h4DrawSlider(h4name$,d) CALL Buttons CALL t1Init CALL t3Init CALL ResetDisplay END SUB ! --- event manager --- DO LET clearflag= 0 DO GET MOUSE: mx,my,ms IF w2wWithin(mx,my)=true then CALL w2Rollover ELSE IF clearflag2=1 then CALL t1ClearValues LET clearflag2= 0 END IF LOOP until ms=2 IF w1Within(mx,my)=true then CALL w1wClamp(mx,my) CALL w2ShowGridLayer LET omx,omy= 999 DO GET MOUSE: mx,my,ms IF w1Within(mx,my)=true then CALL w1DragEvent END IF LOOP until ms=3 ELSE IF w2Within(mx,my)=true then CALL MouseUp(mx,my,ms) LET x0= w2fncx(mx) LET y0= w2fncy(my) CALL t1SetValues(x0,y0) CALL Trajectory(x0,y0) ELSE IF h1Within(mx,my)=true then LET olda= -999 IF myevbLft and mxevbTop and mycLft and mxcTop and mymx or omy<>my then CALL CopyCoords(mx,my,omx,omy) CALL w1PixelsToMath(mx,my,trace,dterm) LET trace= round(trace,3) LET dterm= round(dterm,3) IF abs(dterm)<=.1 then LET dterm= 0 IF abs(trace)<=.1 then LET trace= 0 CALL TraceDetToMat ! CALL LinearParams(a,b,c,d,trace,dterm,dscrm,cmplx) CALL Classify(trace,dterm,dscrm,cmplx,name$,tclr) CALL MarkCursor(trace,dterm) CALL t3SetValue IF lamflag=1 then CALL t4SetValues CALL w2Redraw LET clearflag2= 1 END IF END SUB SUB w2Rollover IF omx<>mx or omy<>my then LET x0= w2fncx(mx) LET y0= w2fncy(my) CALL t1SetValues(x0,y0) LET clearflag2= 1 LET omx= mx LET omy= my END IF END SUB ! ---- slider events ---- ! --- h1 slider events --- SUB h1MouseClick CALL h1GetClickVal(ms,h1Click,ma) CALL h1MouseAction END SUB SUB h1MouseDrag DO CALL h1GetDragVal(ms,h1Places,ma) CALL h1MouseAction LOOP until ms=3 END SUB SUB h1MouseAction IF ma<>oldma then LET a,oldma= ma CALL SliderInputAction CALL MatAReset(ma) END IF END SUB ! --- h2 slider events --- SUB h2MouseClick CALL h2GetClickVal(ms,h2Click,mb) CALL h2MouseAction END SUB SUB h2MouseDrag DO CALL h2GetDragVal(ms,h2Places,mb) CALL h2MouseAction LOOP until ms=3 END SUB SUB h2MouseAction IF mb<>oldmb then LET b,oldmb= mb CALL SliderInputAction CALL MatBReset(mb) END IF END SUB ! --- h3 slider events --- SUB h3MouseClick CALL h3GetClickVal(ms,h3Click,mc) CALL h3MouseAction END SUB SUB h3MouseDrag DO CALL h3GetDragVal(ms,h3Places,mc) CALL h3MouseAction LOOP until ms=3 END SUB SUB h3MouseAction IF mc<>oldmc then LET c,oldmc= mc CALL SliderInputAction CALL MatCReset(mc) END IF END SUB ! --- h4 slider events --- SUB h4MouseClick CALL h4GetClickVal(ms,h4Click,md) CALL h4MouseAction END SUB SUB h4MouseDrag DO CALL h4GetDragVal(ms,h4Places,md) CALL h4MouseAction LOOP until ms=3 END SUB SUB h4MouseAction IF md<>oldmd then LET d,oldmd= md CALL SliderInputAction CALL MatDReset(md) END IF END SUB ! --- SUB SliderInputAction CALL LinearParams(a,b,c,d,trace,dterm,dscrm,cmplx) CALL Classify(trace,dterm,dscrm,cmplx,name$,tclr) CALL t3SetValue CALL MarkCursor(trace,dterm) IF lamflag=1 then CALL t4SetValues CALL w2Redraw END SUB SUB SliderResetAll(a,b,c,d) CALL h1mark(a) CALL h2mark(b) CALL h3mark(c) CALL h4mark(d) END SUB SUB TraceDetToMat LET ma,a,olda= 0 LET mb,b,oldb= 1 LET mc,c,oldc= -dterm LET md,d,oldd= trace CALL ShowMatrixValues CALL SliderResetAll(a,b,c,d) END SUB ! ---- end of slider routines ---- ! --- eigen directions --- SUB w2Redraw CALL w2ShowGridLayer CALL VectorField CALL FindEigenVectors(a,b,c,d) CALL w2KeepGraphLayer END SUB SUB ResetDisplay CALL Classify(trace,dterm,dscrm,cmplx,name$,tclr) CALL ShowMatrixValues CALL MarkCursor(trace,dterm) CALL t3SetValue IF lamflag=1 then CALL t4SetValues CALL w2Redraw END SUB SUB FindEigenVectors(a,b,c,d) CALL LinearParams(a,b,c,d,trace,dterm,dscrm,cmplx) IF abs(dscrm)<.15 then ! one real root LET dterm= (trace*trace)/4 LET dscrm= 0 LET cmplx= 0 LET lam1 = trace/2 LET x= 1 LET y= lam1 ELSE IF dscrm>0 then ! two real roots IF c=0 and d=0 then ! first row points needed? LET x= 2*b LET y= d-a-sqr(dscrm) CALL CheckEigenPoint(x,y) LET y= d-a+sqr(dscrm) CALL CheckEigenPoint(x,y) ELSE ! otherwise second row points IF c<>0 then LET y= 2*c LET x= a-d-sqr(dscrm) CALL CheckEigenPoint(x,y) LET x= a-d+sqr(dscrm) CALL CheckEigenPoint(x,y) ELSE LET y= 0 LET x= 1 CALL CheckEigenPoint(x,y) IF b=0 then LET x= 0 LET y= 1 CALL CheckEigenPoint(x,y) ELSE LET x= 1 LET y= (d-a)/b CALL CheckEigenPoint(x,y) END IF END IF END IF END IF END SUB SUB CheckEigenPoint(x,y) LET w = w2fRgt LET ex= round(x,8) LET ey= round(y,8) IF ex=0 and ey=0 then ! vertical LET wy1= w2Top LET wx1= w2Wndx(0) LET wy2= w2Bas LET wx2= w2Wndx(0) SET COLOR litmid PLOT wx1,wy1; wx2,wy2 ELSE IF abs(ey)>=abs(ex) then ! tall - scale y to 4 LET scl= w/ey CALL DrawEDirection(ex,ey,scl) ELSE IF abs(ex)>abs(ey) then ! wide - scale x to 4 LET scl= w/ex CALL DrawEDirection(ex,ey,scl) END IF END SUB SUB DrawEDirection(vx,vy,scl) LET by = vy*scl LET bx = vx*scl LET wy1= w2Wndy( by) LET wx1= w2Wndx( bx) LET wy2= w2Wndy(-by) LET wx2= w2Wndx(-bx) SET COLOR tclr PLOT wx1,wy1; wx2,wy2 END SUB ! --- end of slider matrix routines --- ! (left branch) -- maybe "repeated eigenvalues (source)". same thing for ! "zero eigenvalue (source)" (right branch), (sink) for left branch. SUB Classify(trace,dterm,dscrm,cmplx,name$,tclr) LET dterm= round(dterm,8) LET trace= round(trace,8) LET dscrm= trace*trace - 4*dterm ! find discriminant IF dscrm<0 then LET cmplx= 1 else LET cmplx= 0 ! complex? IF dterm>0 then ! upper half plane IF a=d and b=0 and c=0 then ! stars IF trace>0 then LET name$= "star source" ! parabola ELSE IF trace<0 then LET name$= "star sink" ! parabola END IF LET tclr = yellow ELSE IF abs(dscrm)<.15 then IF trace>0 then LET name$= "defective nodal source" ! parabola ELSE IF trace<0 then LET name$= "defective nodal sink" ! parabola END IF LET tclr = yellow LET dterm = trace*trace/4 LET dscrm = 0 LET cmplx = 0 CALL TraceDetToMat ELSE IF trace<0 then ! stable IF cmplx=0 then LET name$= "nodal sink" LET tclr = green ELSE LET name$= "spiral sink" LET tclr = red END IF ELSE IF trace>0 then ! unstable IF cmplx=0 then LET name$= "nodal source" LET tclr = magenta ELSE LET name$= "spiral source" LET tclr = cyan END IF ELSE IF trace=0 then LET name$= "center" LET tclr = white END IF ELSE IF dterm<0 then ! saddle LET name$= "saddle" LET tclr = blue ELSE IF dterm=0 then LET tclr= white IF trace=0 then LET name$= "zero eigenvalues" ELSE IF trace<0 then LET name$= "zero eigenvalue (sink)" ELSE IF trace>0 then LET name$= "zero eigenvalue (source)" END IF END IF END IF CALL t2SetName(name$) END SUB SUB FindLamdas SELECT CASE dscrm CASE 0 ! one real root LET lam1,lam2= trace/2 LET l1$= using$("-%.##",lam1) LET l2$= using$("-%.##",lam2) CALL DrawEValues(lam1,lam2) CASE is > 0 ! two real roots LET lam1= (trace+sqr(dscrm))/2 LET lam2= (trace-sqr(dscrm))/2 LET l1$ = using$("-%.##",lam1) LET l2$ = using$("-%.##",lam2) CALL DrawEValues(lam1,lam2) CASE is < 0 ! complex roots LET lam1= trace/2 LET lam2= sqr(-dscrm)/2 LET r$ = trim$(using$("-%.##",lam1)) LET i$ = trim$(using$("-%.##i",abs(lam2))) LET l1$ = r$ & " - " & i$ LET l2$ = r$ & " + " & i$ LET cmplx= 1 CALL DrawEValues(lam1,lam2) END SELECT END SUB SUB MarkCursor(trace,dterm) CALL w1ShowGridLayer CALL w1MathToPixels(trace,dterm,wt,wd) IF wt>=w1Lft and wt<=w1Rgt and wd>=w1Top and wd<=w1Bas then SET COLOR backclr BOX AREA wt-3,wt+3,wd+1,wd-1 BOX AREA wt-1,wt+1,wd+3,wd-3 SET COLOR white PLOT wt-2,wd; wt+2,wd PLOT wt,wd-2; wt,wd+2 END IF END SUB SUB DrawEValues(lam1,lam2) CALL w4ShowGridLayer SET COLOR tclr IF cmplx=0 then LET wx= w4Wndx(lam1) IF wx>w4Lft and wxlam1 then LET wx= w4Wndx(lam2) IF wx>w4Lft and wx=w4Top and wy2<=w4Bas and wx>=w4Lft and wx<=w4Rgt then CALL DrawDiamond5(wx,wy1) CALL DrawDiamond5(wx,wy2) END IF END IF END SUB SUB DrawDiamond5(wdx,wdy) PLOT wdx-2,wdy ; wdx+2,wdy PLOT wdx ,wdy-2; wdx ,wdy+2 BOX LINES wdx-1,wdx+1,wdy+1,wdy-1 END SUB ! SUB FindVector(x,y) ! LET wx= w2Wndx(x) ! LET wy= w2Wndy(y) ! LET dx= dxdt(x,y) ! LET dy= dydt(x,y) ! ! CALL RungeKutta4(x,y,dx,dy,tstep) ! IF dx<>0 or dy<>0 then ! LET ang= angle(dx,-dy) ! DRAW BigVector with rotate(ang) * shift(wx,wy) ! END IF ! END SUB ! PICTURE BigVector ! PLOT -6, 0; 6,0 ! PLOT 3,-3; 6,0; 3,3 ! END PICTURE ! PICTURE ICPointer ! PLOT -3,3; 0,0; -3,-3 ! END PICTURE ! ! PICTURE Vector ! PLOT -4, 0; 4,0 ! PLOT 2,-2; 4,0; 2,2 ! END PICTURE ! ! PICTURE Pointer ! PLOT 0,0; -4,-4 ! PLOT 0,0; -4, 4 ! END PICTURE ! ---- Vector Field routines ---- SUB VectorField SET COLOR drkmid LET vstp= 30 LET hstp= vstp/2 FOR wx= w2Lft+hstp to w2Rgt-hstp step vstp ! draw vector field FOR wy= w2Top+hstp to w2Bas-hstp step vstp LET x = w2fncx(wx) LET y = w2fncy(wy) LET dx= dxdt(x,y) LET dy= dydt(x,y) IF dx<>0 or dy<>0 then LET ang= angle(dx,-dy) LET sa = 10*sin(ang) LET ca = 10*cos(ang) LET wx0= wx+ca LET wy0= wy+sa PLOT wx,wy; wx0,wy0 CALL VectorHead(ang,wx,wy,wx0,wy0) ELSE PLOT wx,wy END IF NEXT wy NEXT wx END SUB SUB VectorHead(ang,wx,wy,wx0,wy0) CALL SetMat(ang) CALL Rotate(6, 2,x1,y1) CALL Rotate(6,-2,x2,y2) LET wx1= wx+x1 LET wy1= wy+y1 LET wx2= wx+x2 LET wy2= wy+y2 PLOT wx1,wy1; wx0,wy0; wx2,wy2 END SUB SUB Rotate(xin,yin,xout,yout) LET xout= xin*vma + yin*vmc LET yout= xin*vmb + yin*vmd END SUB SUB SetMat(ang) LET vma= cos(ang) LET vmb= sin(ang) LET vmc= -vmb LET vmd= vma END SUB ! ---- end of vector field routines --- SUB Trajectory(x0,y0) SET COLOR tclr FOR n= 1 to -1 step -2 LET oldflag= 1 LET stp = n*tstep CALL CopyCoords(x0,y0,x,y) CALL w2MathToPixels(x,y,wx,wy) PLOT w2Wndx(x),w2Wndy(y) FOR i= 1 to 1000 ! draw trajectory CALL CopyCoords(wx,wy,oldwx,oldwy) CALL w2MathToPixels(x,y,wx,wy) IF w2wWithin(wx,wy)=true then IF oldflag=1 then PLOT wx,wy; oldwx,oldwy LET oldflag= 1 ELSE LET oldflag= 0 END IF CALL RungeKutta4(x,y,dx,dy,stp) IF abs(x-x0)10 then IF trace=0 then PLOT EXIT SUB END IF END IF IF (abs(dx)<.005 and abs(dy)<.005) or abs(x)>12 or abs(y)>12 then EXIT FOR END IF GET MOUSE: mx,my,ms IF ms=2 then PLOT EXIT SUB END IF NEXT i PLOT IF trace=0 and dterm>0 then EXIT FOR NEXT n END SUB SUB RungeKutta4(x,y,dx,dy,tstp) LET dx1= dxdt(x,y) LET dy1= dydt(x,y) LET x1 = x + .5*dx1*tstp LET y1 = y + .5*dy1*tstp LET dx2= dxdt(x1,y1) LET dy2= dydt(x1,y1) LET x2 = x + .5*dx2*tstp LET y2 = y + .5*dy2*tstp LET dx3= dxdt(x2,y2) LET dy3= dydt(x2,y2) LET x3 = x + dx3*tstp LET y3 = y + dy3*tstp LET dx4= dxdt(x3,y3) LET dy4= dydt(x3,y3) LET dy = (dy1 + 2*dy2 + 2*dy3 + dy4) / 6 LET dx = (dx1 + 2*dx2 + 2*dx3 + dx4) / 6 LET y = y + tstp*dy LET x = x + tstp*dx END SUB ! --- TD Plane --- SUB DrawTDPlane ! w1 trace and det CALL BoxArea(w1Lft+1,w1Rgt,w1Bas-1,w1y0,blue) CALL BoxArea(w1Lft+1,w1x0-1,w1y0-1,w1Top,green) CALL BoxArea(w1x0+1,w1Rgt,w1y0,w1Top,magenta) FOR wx= w1Lft to w1Rgt ! fill inside parabola LET fx= w1fncx(wx) LET fy= 0.25*fx*fx LET wy= w1Wndy(fy) IF fx<0 then SET COLOR red ELSE SET COLOR cyan END IF PLOT wx,wy; wx,w1Top NEXT wx SET COLOR yellow ! parabola FOR wx= w1Lft to w1Rgt LET fx= w1fncx(wx) LET fy= 0.25*fx*fx LET wy= w1Wndy(fy) IF round(wy)=w1Wndy(0) then LET wy= wy-1 ! stay above 0 IF fx<0 then BOX AREA wx,wx+1,wy+1,wy ELSE BOX AREA wx-1,wx,wy+1,wy END IF NEXT wx PLOT SET COLOR white ! axes PLOT w1Lft,w1y0; w1Rgt,w1y0 PLOT w1x0,w1Top; w1x0,w1y0 END SUB END SUB