rem ==================================================================== rem LineMachine - extends lines into parallelograms, then the lines in rem the parallelograms into new parallelograms, etc. By fnoobler, 2012. rem ==================================================================== rem Instructions - first run the program as it is. rem When its finished a phase the number of lines will stop changing. rem Press key e to continue with the next phase, or press h for help. rem The keys listed in help allow you to move and scale the lines, rem and set the color of lines and the background. rem Using the alpha channel, its possible to compose objects, but its rem not at all user friendly as changes cant be undone. rem If you wonder why it draws a cube and says its got 16 lines, rem its because duplicate lines are created and not removed. rem Try changing the extension vectors VX and VY. rem Most of the other settings relate to position, scale and color, and can be changed after drawing, rem using keys listed by pressing the 'h' key. rem Load font if it's a Java applet. if javac() then load font 0, "courier.txt", "courier.png" set window 0,0,1250,750 visible: rem Must have same numbers as the set window command above. windowX=5 windowY=5 windowW=1250 windowH=750 filename$="lines.txt" rem If aut>0, size is calculated and initial value of S is ignored. aut=1 rem S is array size of line arrays. rem Sizes for each number of extensions when starting with one line: rem 1 4, 2 16, 3 64, 4 256, 5 1024, 6 4096 S=4096 rem Initial lines. sX1[]=[0] sY1[]=[10] sX2[]=[5] sY2[]=[10] rem Extension vectors (applied in sequence). The 9th takes a few minutes, after 9 vectors the time taken rem increases a lot. At some point an extra vector will dneed more memory than available. VX[]=[0,1,2,3,4, 4, 3, 2, 1] VY[]=[5,4,3,2,1,-1,-2,-3,-4] rem If evolve>0, after each extension phase, can alter position and color. evolve=1 rem Scale sX=10 sY=10 rem Offset in pixels, added after scaling. oX=10 oY=10 rem Line color. lineR=254 lineG=254 lineB=254 lineAlpha=254 rem Background color. backR=0 backG=0 backB=0 backAlpha=254 rem eg if =10 then screen is only cleared once every 10 times the lines are drawn. clearPeriod=100 rem One-off background wipe. ooffR=0 ooffG=0 ooffB=0 ooffAlpha=254 leading=16 rem colorMode 1 normal RBGalpha, 2 random, 3 cyclic. colorMode=2 rem Colors used in modes 2 and 3 (random and cyclic). rem colR[]=[254, 0, 0,254, 0,254,254, 0,128,254,128, 0] rem colG[]=[ 0,254, 0,254,254, 0,128,254, 0, 0,254,128] rem colB[]=[ 0, 0,254, 0,254,254, 0,128,254,128, 0,254] colR[]=[254, 0, 0,254, 0,254] colG[]=[ 0,254, 0,254,254, 0] colB[]=[ 0, 0,254, 0,254,254] cycles=3 rem Minimum number of milliseconds between re-drawings when mousebutton is down. flash=500 rem Was to stop orbit getting too big. Using modulus of image instead (freedom, motL motT motW motH). rem speedLimit=10 rem Freedom=100 means 1 window size all round, so image will be in one of 9 windows, and only seen rem if its in the middle one (the real one). freedom=200 rem Size of attX attY. More than enough, 1 attraction point works. maxAtts=100 rem How much alphaPlus adjustment changes when keys f,u,a are pressed. fadeSpeed=64 rem Window centre. windowCX windowCY rem INTERESTING FAILURE rem Try removing 'rem' from: rem aut=0 ; S=2000 ; sX1[]=[0] ; sY1[]=[20] ; sY2[]=[20] ; VX[]=[0,1,2,3,4, 4, 3, 2, 1] ; VY[]=[5,4,3,2,1,-1,-2,-3,-4] rem eg line i is X1[i],Y1[i] to X2[i],Y2[i] X1[S] Y1[S] X2[S] Y2[S] rem Number of lines. nLines rem If >0 then nLines got too big for arrays. Actually counts number of times that happened. fails rem Current extension vector cvx,cvy cvx cvy rem Number of extensions, from size of extension vector arrays. vecs rem Generation (or extension number). gen rem Set to 1 if escape was pressed, 2 for other key except spacebar to stop making lines but still show result. stopMake rem Flag for got Escape or space char when expecting integer input (cuts input short). wantIntGotEsc evolutionComplete rem Number of colors in arrays. numColors rem So screen can be cleared once every period. clearCount row0 row1 row2 row3 row4 cycLen rem Centre of latest bunch of lines, also L R T B. centreX centreY herdL herdR herdT herdB mouseDownX mouseDownY mouseForNextGen rem Attraction points. attX[maxAtts] attY[maxAtts] rem Number of attraction points. atts rem Index for adding attraction points. atti rem Index of attraction point moving to. Position, velocity. wix posX posY velX velY rem Set by key d to slow down. decel rem For keeping image in or near window (if its near its likely to soon be in). motL motT motW motH rem Files reachedEOF doneLines doneVecs doneColors doneBack doneForeClr doneOneOff doneWinSize rem Instead of returning an integer and an array. passHead passNumints rem Speed for HereBoy. speedHB# rem Used to twinkle a line of crosses that alternate with pixel values there before overwrite. twinkleTime rem Used by HereBoy to get points to draw at. HBxLatest[] HByLatest[] rem op for NumberFromKeyPress. r is replace eg prev r (key 8) = 8. numFromKeyOp$ rem For ascii vals. a0 a9 recurCt fromFarTargX fromFarTargY rem Motion and pause flags. inMotionF inMotionFP hereBoyF hereBoyFP runRoundF runRoundFP fromFarF fromFarFP fromFarFBreak teleportF rem For fading and restoring color. alphaPlus hidden: set redraw off proc Initial rem TODO if SettingsFromFile makes changes, it will call Initial again. proc SettingsFromFile proc MakeAndShow evolutionComplete=1 proc Display procedure Initial() a0=asc("0") a9=asc("9") stopMake=0 evolutionComplete=0 inMotionF=0 hereBoyF=0 row0=0 row1=leading row2=leading*2 row3=leading*3 row4=leading*4 windowCX=windowW/2 windowCY=windowH/2 mouseDownX=windowCX mouseDownY=windowCY clearCount=0 speedHB=10.0 rem Set number of lines to number of initial lines. nLines=sizeof(sX1) vecs=sizeof(VX) numColors=sizeof(colR) rem Size line arrays to S, calculating S if flag aut set. if aut>0 S=nLines for i=0 to vecs-1 S=S*4 next endif X1[S] Y1[S] X2[S] Y2[S] rem Copy initial set of lines to the line arrays. for i=0 to nLines-1 X1[i]=sX1[i] Y1[i]=sY1[i] X2[i]=sX2[i] Y2[i]=sY2[i] next endproc procedure SettingsFromFile() set caret 0,0 open file 0, filename$, true if not file(0) then return reachedEOF=0 doneLines=0 doneVecs=0 doneColors=0 doneBack=0 doneForeClr=0 doneOneOff=0 doneWinSize=0 h=0 while reachedEOF<=0 and (doneLines<=0 or doneVecs<=0 or doneColors<=0 or doneBack<=0 or doneForeClr<=0 or doneOneOff<=0 or doneWinSize<=0) h=SectionFromFile(h) write " SetFF h=",h," reachedEOF=",reachedEOF," doneLines=",doneLines," doneVecs=",doneVecs write " doneColors=",doneColors," doneBack=",doneBack," doneForeClr=",doneForeClr," doneOneOff=",doneOneOff," doneWinSize=",doneWinSize redraw wend if doneLines>0 or doneVecs>0 or doneColors>0 or doneBack>0 or doneForeClr>0 or doneOneOff>0 or doneWinSize>0 then proc Initial endproc function SectionFromFile(h) if h=0 rem Need to scan for section heading. do t$=ReadLine() if reachedEOF>0 then return 0 h=AnyHeading(t) if h=1 and doneLines<=0 h=LinesFromFile() write " SFF a t=",t," h=",h redraw wait keydown return h elseif h=2 and doneVecs<=0 h=VecsFromFile() write " SFF b t=",t," h=",h redraw wait keydown return h elseif h=3 and doneColors<=0 write " SFF c t=",t," h=",h redraw wait keydown h=ColorArraysFromFile() return h elseif h=4 and doneBack<=0 write " SFF c t=",t," h=",h redraw wait keydown h=BackgroundFromFile() return h elseif h=5 and doneForeClr<=0 write " SFF c t=",t," h=",h redraw wait keydown h=ForeColorFromFile() return h elseif h=6 and doneOneOff<=0 write " SFF c t=",t," h=",h redraw wait keydown h=OneOffColorFromFile() return h elseif h=7 and doneWinSize<=0 write " SFF c t=",t," h=",h redraw wait keydown h=WinSizeFromFile() return h endif rem TODO same for vecs and colors. loop elseif h=1 and doneLines<=0 rem Lines section write " SFF gen " h=LinesFromFile() return h rem TODO need elseif h=2 vecs, elseif h=3 colors. elseif h=2 and doneVecs<=0 h=VecsFromFile() write " SFF q h=",h," reachedEOF=",reachedEOF redraw wait keydown return h elseif h=3 and doneColors<=0 write " SFF r h=",h," reachedEOF=",reachedEOF redraw wait keydown h=ColorArraysFromFile() return h elseif h=4 and doneBack<=0 write " SFF s h=",h," reachedEOF=",reachedEOF redraw wait keydown h=BackgroundFromFile() return h elseif h=5 and doneForeClr<=0 write " SFF s h=",h," reachedEOF=",reachedEOF redraw wait keydown h=ForeColorFromFile() return h elseif h=6 and doneOneOff<=0 write " SFF s h=",h," reachedEOF=",reachedEOF redraw wait keydown h=OneOffColorFromFile() return h elseif h=7 and doneWinSize<=0 write " SFF s h=",h," reachedEOF=",reachedEOF redraw wait keydown h=WinSizeFromFile() return h else rem Could be eg h=2 but vectors are done. return 0 endif write " SFF exit h=",h," reachedEOF=",reachedEOF redraw endfunc function AnyHeading(u$) f=0 t$=lower$(u) if instr(t,"line")>=0 f=1 elseif instr(t,"vec")>=0 f=2 elseif instr(t,"col")>=0 f=3 elseif instr(t,"back")>=0 f=4 elseif instr(t,"for")>=0 f=5 elseif instr(t,"one")>=0 f=6 elseif instr(t,"win")>=0 f=7 elseif instr(t,"end")>=0 proc CloseFile f=-1 endif return f endfunc function LinesFromFile() set color 254,254,254 passHead=0 ints[]=IntsFromFile() rem wln rem write "LFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown rem doneLines=1 is done but theyre bad, =2 is OK. doneLines=2 if passNumints<4 then doneLines=1 if doneLines=2 rem Copy to initial lines. nLines=passNumints/4 sX1[nLines] sY1[nLines] sX2[nLines] sY2[nLines] ix=0 for i=0 to nLines-1 sX1[i]=ints[ix] ix=ix+1 sY1[i]=ints[ix] ix=ix+1 sX2[i]=ints[ix] ix=ix+1 sY2[i]=ints[ix] ix=ix+1 next write "LFF b nLines=",nLines," sX1 sY1 sX2 sY2 =" for j=0 to nLines-1 write " ",sX1[j],",",sY1[j],",",sX2[j],",",sY2[j] next wln redraw wait keydown endif return passHead endfunc function VecsFromFile() set color 254,254,254 passHead=0 ints[]=IntsFromFile() wln write "VFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown rem doneVecs=1 is done but theyre bad, =2 is OK. doneVecs=2 if passNumints<2 then doneVecs=1 if doneVecs=2 rem Copy to vectors. vecs=passNumints/2 VX[vecs] VY[vecs] ix=0 for i=0 to vecs-1 VX[i]=ints[ix] ix=ix+1 VY[i]=ints[ix] ix=ix+1 next write "VFF b passHead=",passHead," vecs=",vecs," VX VY =" for j=0 to vecs-1 write " ",VX[j],",",VY[j] next wln redraw wait keydown endif return passHead endfunc function ColorArraysFromFile() set color 254,254,254 wln write "CFF a " redraw passHead=0 ints[]=IntsFromFile() rem wln rem write "CFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown rem doneColors=1 is done but theyre bad, =2 is OK. doneColors=2 if passNumints<3 then doneColors=1 if doneColors=2 rem Copy to color arrays. numColors=passNumints/3 colR[numColors] colG[numColors] colB[numColors] ix=0 for i=0 to numColors-1 c=ints[ix] colR[i]=abs(c)%255 ix=ix+1 c=ints[ix] colG[i]=abs(c)%255 ix=ix+1 c=ints[ix] colB[i]=abs(c)%255 ix=ix+1 next write "CFF b passHead=",passHead," numColors=",numColors," colR colG colB =" for j=0 to numColors-1 write " ",colR[j],",",colG[j],",",colB[j] next wln redraw wait keydown endif return passHead endfunc function BackgroundFromFile() set color 254,254,254 wln write "BFF a " redraw passHead=0 ints[]=IntsFromFile() rem wln rem write "BFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown doneBack=2 rem Copy to background color settings. if passNumints>0 then backR=ColorChanInRange(ints[0]) if passNumints>1 then backG=ColorChanInRange(ints[1]) if passNumints>2 then backB=ColorChanInRange(ints[2]) if passNumints>3 then backAlpha=ColorChanInRange(ints[3]) if passNumints>4 then clearPeriod=abs(ints[4]) rem write "BFF b passHead=",passHead," passNumints=",passNumints," backR=",backR," backG=",backG," backB=",backB," backAlpha=",backAlpha write "BFF b passHead=",passHead," passNumints=",passNumints," backR=",backR," backG=",backG," backB=",backB," backAlpha=",backAlpha," clearP=",clearPeriod wln redraw wait keydown return passHead endfunc function ForeColorFromFile() set color 254,254,254 wln write "LFF a " redraw passHead=0 ints[]=IntsFromFile() rem wln rem write "LFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown doneForeClr=2 rem Copy to background color settings. if passNumints>0 then lineR=ColorChanInRange(ints[0]) if passNumints>1 then lineG=ColorChanInRange(ints[1]) if passNumints>2 then lineB=ColorChanInRange(ints[2]) if passNumints>3 then lineAlpha=ColorChanInRange(ints[3]) write "LFF b passHead=",passHead," passNumints=",passNumints," lineR=",lineR," lineG=",lineG," lineB=",lineB," lineAlpha=",lineAlpha wln redraw wait keydown return passHead endfunc function OneOffColorFromFile() set color 254,254,254 wln write "OFF a " redraw passHead=0 ints[]=IntsFromFile() rem wln rem write "OFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown doneForeClr=2 rem Copy to background color settings. if passNumints>0 then ooffR=ColorChanInRange(ints[0]) if passNumints>1 then ooffG=ColorChanInRange(ints[1]) if passNumints>2 then ooffB=ColorChanInRange(ints[2]) if passNumints>3 then ooffAlpha=ColorChanInRange(ints[3]) write "OFF b passHead=",passHead," passNumints=",passNumints," ooffR=",ooffR," ooffG=",ooffG," ooffB=",ooffB," ooffAlpha=",ooffAlpha wln redraw wait keydown return passHead endfunc function ColorChanInRange(c) r=abs(c)%255 return r endfunc function WinSizeFromFile() set color 254,254,254 wln write "WFF a " redraw passHead=0 ints[]=IntsFromFile() rem wln rem write "WFF passNumints=",passNumints," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown rem doneVecs=1 is done but theyre bad, =2 is OK. doneWinSize=2 rem Copy to background color settings. if passNumints>0 then windowX=ints[0] if passNumints>1 then windowY=ints[1] if passNumints>2 then windowW=ints[2] if passNumints>3 then windowH=ints[3] set window windowX,windowY,windowW,windowH write "WFF b passHead=",passHead," passNumints=",passNumints," windowX=",windowX," windowY=",windowY," windowW=",windowW," windowH=",windowH wln redraw wait keydown return passHead endfunc function IntsFromFile[]() rem set color 254,254,254 ary[] ints[4000] ix=0 do t$=ReadLine() rem wait 10 rem wln " IFF t=",t," reachedEOF=",reachedEOF rem redraw if reachedEOF>0 then break h=AnyHeading(t) rem If h=-1 its hit 'end' and file has been closed. if h<0 then break rem If its hit a heading, need to return heading type. if h>0 passHead=h break endif ary[] ary[]=IntsFromString(t) if sizeof(ary)>0 for i=1 to ary[0] ints[ix]=ary[i] ix=ix+1 if ix>=sizeof(ints) then break next endif rem write " IFF size(ary)=",sizeof(ary) rem if sizeof(ary)>0 rem for j=0 to 10 rem write " ",ary[j] rem next rem write " ix=",ix," ints=" rem for j=0 to 30 rem write " ",ints[j] rem next rem wln rem redraw rem wait keydown rem endif loop passNumints=ix rem wait keydown return ints endfunc function IntsFromString[](t$) ary[101] c=0 i=0 ix=1 s=len(t) d$="" for i=0 to s-1 a$=mid$(t,i) if asc(a)>=a0 and asc(a)<=a9 d=d+a else if len(d)>0 ary[ix]=int(d) ix=ix+1 if ix>100 then break d="" endif if a="-" then d=a endif next rem If the last character is a digit then the last number (in d) wont be in the array. if ix<101 and len(d)>0 ary[ix]=int(d) ix=ix+1 endif rem Put count in array and return. ary[0]=ix-1 return ary endfunc function ReadLine$() do t$ = ReadLine2() if reachedEOF>0 or len(t)<4 or left$(t,4)<>"rem " then return t loop endfunc function ReadLine2$() t$ = FileReadLine() rem wln "ReadLine: ", t, "!", len(t), " ", f dummy=EndOfFile() rem wln "ReadLine: dummy=", dummy return t endfunc function FileReadLine$() s$ c = read8(0) while not (eof(0) or c = 13) rem Get rid of line feed character. if not c = 10 then s = s + chr$(c) c = read8(0) wend return s endfunc function EndOfFile() if reachedEOF<=0 if eof(0) rem wln "EndOfFile about to close ", f free file 0 reachedEOF=1 rem wln "EndOfFile closed ", f endif endif if reachedEOF<=0 then return 1 return 0 endfunc procedure CloseFile() free file 0 reachedEOF=1 endproc procedure MakeAndShow() gen=0 while gen0 and stopMake<=0 then proc Display if stopMake>0 then break gen=gen+1 wend endproc procedure ExtendLines() rem Update extension vectors for generation. cvx=VX[gen] cvy=VY[gen] rem Use a copy of nLines for the loop, as nLines is increased when new lines made. n2=nLines for i=0 to n2-1 proc ExtendLine X1[i],Y1[i],X2[i],Y2[i] wait 1 ky=inkey() rem Esc (27) to quit, spacebar (32) to show then continue making lines, any other key to stop making and show. if ky>0 if ky=27 stopMake=1 break elseif ky=32 proc ShowTheLot else stopMake=2 break endif endif if 0=i%100 rem Occasional small change on screen to show working. set color backR,backG,backB draw rect 0,0,250,row1,1 set caret 0,0 set color 254,254,254 if backR+backG+backB>384 then set color 0,0,0 write " "+str$(nLines)+" lines, generation ",gen+1," of ",sizeof(VX) redraw endif next proc FindCentre endproc procedure ExtendLine(x1,y1,x2,y2) proc MakeNewLine x1,y1,x1+cvx,y1+cvy proc MakeNewLine x1+cvx,y1+cvy,x2+cvx,y2+cvy proc MakeNewLine x2+cvx,y2+cvy,x2,y2 endproc procedure MakeNewLine(x1,y1,x2,y2) rem The test and modulus is so if nLines is too big for the arrays, it fails interestingly. if nLines>=S nLines=nLines%S fails=fails+1 endif X1[nLines]=x1 Y1[nLines]=y1 X2[nLines]=x2 Y2[nLines]=y2 nLines=nLines+1 endproc procedure FindCentre() if nLines<1 then return herdL=X1[0] herdR=herdL herdT=Y1[0] herdB=herdT for i=0 to nLines-1 if X1[i]herdR then herdR=X1[i] if Y1[i]herdB then herdB=Y1[i] if X2[i]herdR then herdR=X2[i] if Y2[i]herdB then herdB=Y2[i] next centreX=(herdL+herdR)/2 centreY=(herdT+herdB)/2 endproc procedure Display() rem Quit if escape was pressed. if stopMake=1 then return if fails>0 w=fails*S+nLines write "Needs size at least "+str$(w)+"." else set color backR,backG,backB draw rect 0,0,250,row1,1 set caret 0,0 set color 254,254,254 if backR+backG+backB>384 then set color 0,0,0 write " "+str$(nLines)+" lines, generation ",gen+1," of ",sizeof(VX) endif redraw mouseForNextGen=0 do wait 1 ky=inkey() c$=chr$(ky) c=lower$(c) if ky>0 done=CommonKeyEdit(ky,c) if done<=0 rem h,H,? or / for help. if c="h" or c="?" proc Help rem 2 for help2. elseif c="1" proc Help1 elseif c="2" proc Help2 elseif c="3" proc Help3 elseif c="4" proc Help4 elseif c="5" proc Help5 elseif c="6" proc Help6 elseif c="7" proc Help7 elseif c="8" proc Help8 elseif c="9" proc Help9 elseif c="0" proc Help10 rem Esc (27) to quit. elseif ky=27 stopMake=1 break elseif c="m" proc Motion rem g or G or space to quit Display for next stage. elseif (c="g" or c="G" or ky=13) and evolve>0 and evolutionComplete<=0 mouseForNextGen=1 else rem set color 254,254,0 rem set caret 100,0 rem write "m",m proc ShowTheLot endif endif else wait 1 m=mousebutton(0) if m>0 mouseDownX=mousex() mouseDownY=mousey() rem if evolve>0 and evolutionComplete<=0 then return if mouseForNextGen>0 then return rem Shift lines to mousedown as ShowTheLot centres on mouseDownX/Y. proc ShowTheLot wait flash endif endif loop endproc function CommonKeyEdit(ky,c$) rem Accessed from Display and Motion. done=1 rem i for info. if c="i" proc Info rem s or S for scale. elseif c="s" proc Scale rem c or C for line color. elseif c="c" proc SetForeColor rem b or B for background color. elseif c="b" proc SetBackgroundColor rem o or O for one-off clear-screen with specified color. elseif c="o" proc OneOffBackgroundWipe elseif c="w" proc ResizeWindow elseif c="f" proc FlashTime rem Home key calls HereBoy if its not running. elseif ky=36 and hereBoyF<=0 proc HereBoy elseif c="r" and hereBoyF<=0 proc RunRound elseif c="t" and teleportF<=0 proc Teleport rem Backspace or Delete erase at mouseDownX/Y. rem elseif ky=8 or ky=127 rem e E Backspace or Delete erase at mouseDownX/Y. elseif c="e" rem Get sample, usually of background. do wait 1 m=mousebutton(0) if m>0 x=mousex() y=mousey() ary[]=pixel(x,y) set color ary[0],ary[1],ary[2] proc ShowWithCurrentColor rem Give time for mouse up. wait flash break endif loop else done=0 endif return done endfunc procedure Help() proc TextRect set caret 0,row0 write " Help 0 of 10 index" set caret 0,row1 write " 1 - background color (b), 5 - generate (g), 9 - window (w)" set caret 0,row2 write " 2 - foreground color (c), 6 - motion (m) 0 - other keys" set caret 0,row3 write " 3 - erase (e), 7 - one-off background wipe (o)" set caret 0,row4 write " 4 - flash time (f), 8 - scale (s)" redraw endproc procedure Help1() proc TextRect set caret 0,row0 write " Help 1 of 10 background color" set caret 0,row1 write " keys: b or B" set caret 0,row3 write " Takes four numbers for RGB color and alpha channel." set caret 0,row4 write " With a low alpha channel value (eg 16) old images fade away." redraw endproc procedure Help2() proc TextRect set caret 0,row0 write " Help 2 of 10 foreground color" set caret 0,row1 write " keys: c or C" set caret 0,row2 write " For setting the color mode (normal RGB+alpha, random or cyclic)," set caret 0,row3 write " and making the settings the mode needs. Try this: Make plenty of lines," set caret 0,row4 write " press m for motion, click, then try cyclic with 1 to 4 cycles." redraw endproc procedure Help3() proc TextRect set caret 0,row0 write " Help 3 of 10 erase" set caret 0,row1 write " keys: e or E" set caret 0,row2 write " To erase the latest drawing, press e then click on the background" set caret 0,row3 write " (to sample the color)." set caret 0,row4 rem write " This will leave holes in any drawings underneath." write " If there are drawings underneath, they'll be left with gaps." redraw endproc procedure Help4() proc TextRect set caret 0,row0 write " Help 4 of 10 flash time" set caret 0,row1 write " keys: f or F" set caret 0,row2 write " When color is random (with key c), with the mouse button held down," set caret 0,row3 write " the lines change color, faster if flash time is lower," set caret 0,row4 write " eg twice a second if flash time = 500 milliseconds." redraw endproc procedure Help5() proc TextRect set caret 0,row0 write " Help 5 of 10 generate" set caret 0,row1 if evolve>0 and evolutionComplete<=0 write " keys: g, G or Return" set caret 0,row3 write " Press g, G or Return then click where you want the next" set caret 0,row4 write " generation of lines to be centred." elseif evolve<=0 set caret 0,row1 write " Can't edit until all generations done. Access denied etc." elseif evolutionComplete>0 write " All generations completed." endif set caret 0,row4 write " " redraw endproc procedure Help6() proc TextRect set caret 0,row0 write " Help 6 of 10 motion" set caret 0,row1 write " keys: m or M" set caret 0,row2 write " Press 'm' and click. You might want to set the background with b first." set caret 0,row3 write " Try with background 254 32 32 2 100 (2 low alpha, wiped once every 100" set caret 0,row4 write " drawings). Motion has its own help, press h and you'll see its index." redraw endproc procedure Help7() proc TextRect set caret 0,row0 write " Help 7 of 10 one-off background wipe" set caret 0,row1 write " keys: o or O" set caret 0,row2 write " This colors the background but leaves the normal background unchanged." set caret 0,row3 write " Usually used with a high alpha, when the normal background setting has" set caret 0,row4 write " a low alpha value (like painting a strong color then washes over it)." redraw endproc procedure Help8() proc TextRect set caret 0,row0 write " Help 8 of 10 scale" set caret 0,row1 write " keys: s or S" set caret 0,row3 write " eg if you want the lines twice as long and the old scale is 15, set to 30." set caret 0,row4 write " eg stretch horizontally by setting scale X to 40, scale Y to 20." redraw endproc procedure Help9() proc TextRect set caret 0,row0 write " Help 9 of 10 window" set caret 0,row1 write " keys: w or W" set caret 0,row2 write " Set window width and height, in pixels." set caret 0,row3 write " (By reducing the window width and then increasing it," set caret 0,row4 write " you can make the right half of the window black.)" redraw endproc procedure Help10() proc TextRect set caret 0,row0 write " Help 10 of 10 other keys" set caret 0,row1 write " keys: i, I - info. h, H - help index. Escape - quit." set caret 0,row2 write " Entering numbers:" set caret 0,row3 write " Use Return to skip (keeping the old number)." set caret 0,row4 write " Enter space then return to skip the rest of the input." redraw endproc procedure Info() proc TextRect set caret 0,row0 write " Info" set caret 0,row1 write " "+str$(nLines)+" lines" if gen>0 then write " (including duplicates)" write ", " if evolutionComplete>0 write "All generation completed." else write " generation ",gen+1," of ",sizeof(VX) endif rem set caret 0,row2 rem if evolve>0 and evolutionComplete<=0 rem write " Press spacebar (or 'e') then click for next generation." rem endif set caret 0,row3 rem write " Tip - Alt and Print Screen button then paste, " rem set caret 0,row3 write " Written in NaaLaa by fnoobler, 2012" redraw endproc procedure Scale() t$=" Previous scale X "+str$(sX)+" Y "+str$(sY) set redraw on wantIntGotEsc=0 proc GetXScale t if wantIntGotEsc<=0 then proc GetYScale t rem 99 so it wont hilite anything. proc OldAndNewScale t,99 set redraw off rem proc ShowTheLot endproc procedure GetXScale(t$) proc OldAndNewScale t,0 set caret 0,row2 write " scale X? " sX=GetIntOrKeepOld(sX) endproc procedure GetYScale(t$) proc OldAndNewScale t,1 set caret 0,row2 write " scale Y? " sY=GetIntOrKeepOld(sY) endproc procedure OldAndNewScale(t$,i) rem proc OldAndNewSettings t,i,4," Current offset X ",oX,", Y ",oY,", scale X ",sX,", Y ",sY,"",0 proc OldAndNewSettings t,i,2," Current scale X ",sX,", Y ",sY,"",0,"",0,"",0 endproc procedure ResizeWindow() t$=" Previous window width "+str$(windowW)+" height "+str$(windowH) set redraw on wantIntGotEsc=0 proc GetWindowW t if wantIntGotEsc<=0 then proc GetWindowH t rem 99 so it wont hilite anything. proc OldAndNewWindow t,99 windowW=max(200,windowW) windowH=max(50,windowH) set window 0,0,windowW,windowH windowCX=windowW/2 windowCY=windowH/2 set redraw off rem proc ShowTheLot endproc procedure GetWindowW(t$) proc OldAndNewWindow t,0 set caret 0,row2 write " window width? " windowW=GetIntOrKeepOld(windowW) endproc procedure GetWindowH(t$) proc OldAndNewWindow t,1 set caret 0,row2 write " window height? " windowH=GetIntOrKeepOld(windowH) endproc procedure OldAndNewWindow(t$,i) proc OldAndNewSettings t,i,2," Current window width ",windowW,", height ",windowH,"",0,"",0,"",0 endproc procedure FlashTime() t$=" Previous flash time (milliseconds) "+str$(flash) set redraw on wantIntGotEsc=0 proc GetFlash t rem 99 so it wont hilite anything. proc OldAndNewFlash t,99 set redraw off endproc procedure GetFlash(t$) proc OldAndNewFlash t,0 set caret 0,row2 write " flash time (milliseconds)? " flash=GetIntOrKeepOld(flash) endproc procedure OldAndNewFlash(t$,i) proc OldAndNewSettings t,i,1," Current flash time (milliseconds) ",flash,"",0,"",0,"",0,"",0 endproc procedure SetForeColor() set redraw on alphaPlus=0 rem mode 1 normal, 2 random, 3 cyclic. if colorMode=2 t$=" Previous line color: Mode 2 (random) alpha "+str$(lineAlpha) elseif colorMode=3 t$=" Previous line color: Mode 3 (cyclic) cycles "+str$(cycles)+", alpha "+str$(lineAlpha) else t$=" Previous line color: Mode 1 (normal) R "+str$(lineR)+", G "+str$(lineG)+", B "+str$(lineB)+", alpha "+str$(lineAlpha) endif wantIntGotEsc=0 proc GetLineMode(t) if wantIntGotEsc<=0 if colorMode=2 proc SetForeColorNowRandom t elseif colorMode=3 proc SetForeColorNowCyclic t else proc SetForeColorNowNormal t endif endif proc OldAndNewColor t,99 set redraw off rem proc ShowTheLot endproc procedure GetLineMode(t$) proc OldAndNewColor t,0 set caret 0,row2 write " mode (1 normal, 2 random, 3 cyclic)? " colorMode=GetIntOrKeepOld(colorMode) colorMode=1+(998+colorMode)%3 endproc procedure SetForeColorNowNormal(t$) proc GetLineR t,1 if wantIntGotEsc<=0 then proc GetLineG t,2 if wantIntGotEsc<=0 then proc GetLineB t,3 if wantIntGotEsc<=0 then proc GetLineAlpha t,4 endproc procedure SetForeColorNowRandom(t$) wantIntGotEsc=0 proc GetLineAlpha t,1 endproc procedure SetForeColorNowCyclic(t$) wantIntGotEsc=0 proc GetLineCycles t if wantIntGotEsc<=0 then proc GetLineAlpha t,2 endproc procedure GetLineCycles(t$) proc OldAndNewColor t,1 set caret 0,row2 write " cycles? " cycles=GetIntOrKeepOld(cycles) endproc procedure GetLineR(t$,i) proc OldAndNewColor t,i set caret 0,row2 write " R? " lineR=GetIntOrKeepOld(lineR) endproc procedure GetLineG(t$,i) proc OldAndNewColor t,i set caret 0,row2 write " G? " lineG=GetIntOrKeepOld(lineG) endproc procedure GetLineB(t$,i) proc OldAndNewColor t,i set caret 0,row2 write " B? " lineB=GetIntOrKeepOld(lineB) endproc procedure GetLineAlpha(t$,i) proc OldAndNewColor t,i set caret 0,row2 write " alpha? " lineAlpha=GetIntOrKeepOld(lineAlpha) endproc procedure OldAndNewColor(t$,i) rem proc OldAndNewSettings t,i,4," Current line color R ",lineR,", G ",lineG,", B ",lineB,", alpha ",lineAlpha,"",0 u$=" Current line color: Mode " rem mode 1 normal, 2 random, 3 cyclic. if colorMode=2 proc OldAndNewSettings t,i,2,u,colorMode," (random), alpha ",lineAlpha,"",0,"",0,"",0 elseif colorMode=3 proc OldAndNewSettings t,i,3,u,colorMode," (cyclic), cycles ",cycles,", alpha ",lineAlpha,"",0,"",0 else proc OldAndNewSettings t,i,5,u,colorMode," (normal), R ",lineR,", G ",lineG,", B ",lineB,", alpha ",lineAlpha endif endproc procedure SetBackgroundColor() t$=" Previous back color R "+str$(backR)+", G "+str$(backG)+", B "+str$(backB)+", alpha "+str$(backAlpha)+", period "+str$(clearPeriod) set redraw on wantIntGotEsc=0 proc GetBackgroundR(t) if wantIntGotEsc<=0 then proc GetBackgroundG(t) if wantIntGotEsc<=0 then proc GetBackgroundB(t) if wantIntGotEsc<=0 then proc GetbackAlpha(t) if wantIntGotEsc<=0 then proc GetclearPeriod(t) proc OldAndNewBackground t,99 set redraw off rem proc ShowTheLot endproc procedure GetBackgroundR(t$) proc OldAndNewBackground t,0 set caret 0,row2 write " R? " backR=GetIntOrKeepOld(backR) endproc procedure GetBackgroundG(t$) proc OldAndNewBackground t,1 set caret 0,row2 write " G? " backG=GetIntOrKeepOld(backG) endproc procedure GetBackgroundB(t$) proc OldAndNewBackground t,2 set caret 0,row2 write " B? " backB=GetIntOrKeepOld(backB) endproc procedure GetbackAlpha(t$) proc OldAndNewBackground t,3 set caret 0,row2 write " alpha? " backAlpha=GetIntOrKeepOld(backAlpha) endproc procedure GetclearPeriod(t$) proc OldAndNewBackground t,4 set caret 0,row2 write " clear-period? " clearPeriod=GetIntOrKeepOld(clearPeriod) endproc procedure OldAndNewBackground(t$,i) proc OldAndNewSettings t,i,5," Current back color R ",backR,", G ",backG,", B ",backB,", alpha ",backAlpha,", period ",clearPeriod endproc procedure OneOffBackgroundWipe() t$=" Previous one-off color R "+str$(ooffR)+", G "+str$(ooffG)+", B "+str$(ooffB)+", alpha "+str$(ooffAlpha) set redraw on wantIntGotEsc=0 proc GetOneOffR(t) if wantIntGotEsc<=0 then proc GetOneOffG(t) if wantIntGotEsc<=0 then proc GetOneOffB(t) if wantIntGotEsc<=0 then proc GetOneOffAlpha(t) proc OldAndNewBackground t,99 set color ooffR,ooffG,ooffB,ooffAlpha cls set redraw off endproc procedure GetOneOffR(t$) proc OldAndNewOneOffWipe t,0 set caret 0,row2 write " R? " ooffR=GetIntOrKeepOld(ooffR) endproc procedure GetOneOffG(t$) proc OldAndNewOneOffWipe t,1 set caret 0,row2 write " G? " ooffG=GetIntOrKeepOld(ooffG) endproc procedure GetOneOffB(t$) proc OldAndNewOneOffWipe t,2 set caret 0,row2 write " B? " ooffB=GetIntOrKeepOld(ooffB) endproc procedure GetOneOffAlpha(t$) proc OldAndNewOneOffWipe t,3 set caret 0,row2 write " alpha? " ooffAlpha=GetIntOrKeepOld(ooffAlpha) endproc procedure OldAndNewOneOffWipe(t$,i) proc OldAndNewSettings t,i,4," Current one-off color R ",ooffR,", G ",ooffG,", B ",ooffB,", alpha ",ooffAlpha,"",0 endproc procedure OldAndNewSettings(t$,i,h,t1$,m1,t2$,m2,t3$,m3,t4$,m4,t5$,m5) rem i is index of number to hilite with red color, h is how many numbers to use. proc TextRect set caret 0,row0 write t set caret 0,row1 set color 254,254,254 if h<1 then return write t1 if i=0 then set color 254,128,0 write str$(m1) set color 254,254,254 if h<2 then return write t2 if i=1 then set color 254,128,0 write str$(m2) set color 254,254,254 if h<3 then return write t3 if i=2 then set color 254,128,0 write str$(m3) set color 254,254,254 if h<4 then return write t4 if i=3 then set color 254,128,0 write str$(m4) set color 254,254,254 if h<5 then return write t5 if i=4 then set color 254,128,0 write str$(m5) set color 254,254,254 endproc function GetIntOrKeepOld(i) s$=rln$() if len(s)=0 then return i rem Esc or space key stops more input c$=left$(s,1) if c=" " or asc(c)=27 wantIntGotEsc=1 return i endif j=int(s) return j endfunc procedure TextRect() rem set color 0,0,196 set color 0,0,128 if inMotionF>0 then set color 0,0,0,222 if hereBoyF>0 then set color 0,64,0,222 draw rect 0,0,600,80,1 proc DrawStatusLines set color 254,244,16 endproc procedure Motion() inMotionF=1 rem Get points in attX/attY then get lines centre to visit them cyclically. rem atts=0 rem atti is index for adding attraction points, wix is visi for moving to. rem atti=0 rem wix=0 rem posX=mouseDownX rem posY=mouseDownY rem velX=0 rem velY=0 rem proc MotionModBox proc MotionAndHereBoyInit do wait 1 m=mousebutton(0) if m>0 mx=mousex() my=mousey() makeWay=0 if atts>0 rem Dont make new attraction point if too close to last one. ixp=(atti+maxAtts-1)%maxAtts d1=attX[ixp]-mx d2=attY[ixp]-my if d1*d1+d2*d2>100 then makeWay=1 rem proc DBGwrite 900,40," " rem wln " Motion atts=",atts," attX/Y=",attX[0],",",attY[0]," ",attX[1],",",attY[1]," ",attX[2],",",attY[2]," " rem write " ixp=",ixp," attX[ixp]=",attX[ixp]," attY[ixp]=",attY[ixp]," mx=",mx," my=",my," d1=",d1," d2=",d2 rem write " d1*d1+d2*d2=",d1*d1+d2*d2," makeWay=",makeWay else makeWay=1 endif if makeWay>0 attX[atti]=mx attY[atti]=my rem draw line mx-4,my-4,mx+4,my+4 rem draw line mx-4,my+4,mx+4,my-4 rem arg ,2 is draw color in contrast to near point. proc DrawAttractionPoint mx,my,2,0,0,0 atti=(atti+1)%maxAtts atts=min(maxAtts,atts+1) endif rem Give time for mouse up. wait 100 else ky=inkey() rem TODO encapse key stuff from Display to ReactToKeys. if ky>0 c$=chr$(ky) c=lower$(c) if c=" " or c="p" dummy=PauseMotion() else exit=MotionKeyEdit(ky,c) if exit>0 then break endif endif endif if atts>0 then proc MoveCentre loop inMotionF=0 endproc function MotionKeyEdit(ky,c$) if c="x" or ky=27 rem Return 1 to exit motion unless paused. return 1 elseif c="m" rem Put the lines in the centre and reset velocity. posX=windowCX posY=windowCY velX=0 velY=0 elseif c="d" rem Toggle slow-down mode. See above, can press d to decel and end pause at the same time. decel=(decel+1)%2 elseif c="n" rem Normal, cancel slow-down mode. decel=0 elseif c="f" or c="<" or c="," rem Fade. alphaPlus=max(1-lineAlpha,alphaPlus-fadeSpeed) elseif c="u" or c=">" or c="." rem Unfade. alphaPlus=min(254-lineAlpha,alphaPlus+fadeSpeed) elseif c="a" rem Restore alpha. if alphaPlus>0 alphaPlus=max(0,alphaPlus-fadeSpeed) elseif alphaPlus<0 alphaPlus=min(0,alphaPlus+fadeSpeed) endif elseif (c="g" or c="G" or ky=13) and evolutionComplete<=0 rem proc ExtendLines gen=gen+1 elseif (ky=8 or ky=127) rem Backspace or Delete cancel attraction point. proc CancelAtt ky rem elseif c="t" and teleportF<=0 rem proc Teleport elseif c="h" or c="1" or c="2" or c="3" or c="4" or c="5" or c="6" or c="7" or c="8" or c="9" proc MotionHelp ky,c else done=CommonKeyEdit(ky,c) rem Needs recalc if scaled. if done>0 then proc MotionModBox endif return 0 endfunc function PauseMotion() rem Pause. (doesnt need to be a function any more) inMotionFP=1 proc DrawStatusLines redraw wait 500 do wait 10 if mousebutton(0)>0 then break rem if inkey()>0 or mousebutton(0)>0 then break ky=inkey() c$=chr$(ky) c=lower$(c) if c="z" or c=" " or c="p" inMotionFP=0 return ky else dummy=MotionKeyEdit(ky,c) rem Needs recalc if scaled or generated. if c="s" or c="g" then proc MotionModBox endif loop inMotionFP=0 return 0 endfunc procedure MotionHelp(ky,c$) do if c="h" proc MotionHelpH elseif c="1" proc MotionHelp1 elseif c="2" proc MotionHelp2 elseif c="3" proc MotionHelp3 elseif c="4" proc MotionHelp4 elseif c="5" proc MotionHelp5 elseif c="6" proc MotionHelp6 elseif c="i" proc Info else break endif rem ky=PauseMotion() wait 400 ky=0 do wait 10 if mousebutton(0)>0 then break ky=inkey() if ky>0 then break loop c$=chr$(ky) c=lower$(c) loop endproc procedure MotionHelpH() proc TextRect set caret 0,row0 write " Motion Help 0 of 0-6 index" set caret 0,row1 write " 1 - decelerate (d), 2 - normal acceleration (n), 3 - attraction points." set caret 0,row2 write " 4 - pause (spacebar or p), 5 - centre the lines (m), 6 - exit motion." set caret 0,row3 write " These keys have help in the main section, but not here:" set caret 0,row4 write " b backgrd, c color, e erase, g gen, i info, o one wipe, s scale, w window." redraw endproc procedure MotionHelp1() proc TextRect set caret 0,row0 write " Motion Help 1 of 0-6 decelerate" set caret 0,row1 write " key: d or D - decelerate" set caret 0,row2 write " Reduces speed. If paused, d will resume motion and decelerate at the" set caret 0,row3 write " same time. After d, d or n will resume normal acceleration." set caret 0,row4 write " 2 - normal acceleration" redraw endproc procedure MotionHelp2() proc TextRect set caret 0,row0 write " Motion Help 2 of 0-6 normal acceleration" set caret 0,row1 write " key: n or N - normal acceleration" set caret 0,row2 write " Key n cancels the effect of d. If paused, n will resume motion and normal" set caret 0,row3 write " acceleration at the same time." set caret 0,row4 write " 3 - attraction points" redraw endproc procedure MotionHelp3() proc TextRect set caret 0,row0 write " Motion Help 3 of 0-6 attraction points" set caret 0,row1 write " Mouse clicks create attraction points. Only one is needed." set caret 0,row2 write " keys: Backspace or Delete." set caret 0,row3 write " Both delete the latest point. Backspace erases the cross from the window." set caret 0,row4 write " 4 - pause" redraw endproc procedure MotionHelp4() proc TextRect set caret 0,row0 write " Motion Help 4 of 0-6 pause" set caret 0,row1 write " key: spacebar, p or P - pause" set caret 0,row2 write " Pauses motion. z p, spacebar or a mouse click will resume." set caret 0,row3 write " Pause can be used to make several changes at once, like color or next gen." set caret 0,row4 write " 5 - centre the lines" redraw endproc procedure MotionHelp5() proc TextRect set caret 0,row0 write " Motion Help 5 of 0-6 centre the lines" set caret 0,row1 write " key: m or M" set caret 0,row2 write " Motion restarts from the centre of the window, with zero velocity." set caret 0,row3 write " The background is only cleared (noticeably) if it has a high alpha." set caret 0,row4 write " 6 - exiting" redraw endproc procedure MotionHelp6() proc TextRect set caret 0,row0 write " Motion Help 6 of 0-6 exit motion" set caret 0,row1 write " keys: x or Escape" set caret 0,row2 write " The background is only cleared (noticeably) if it has a high alpha," set caret 0,row3 write " and might not be cleared is it has period>1." set caret 0,row4 write " h - help index" redraw endproc procedure CancelAtt(ky) rem Backspace or Delete cancel attraction point. if atts<2 then return rem atti=atti%maxAtts atti=(maxAtts+atti-1)%maxAtts rem If Backspace, remove mark. ,1 is use nearby sample and ignore color args. if ky=8 then proc DrawAttractionPoint attX[atti],attY[atti],1,0,0,0 endif atts=atts-1 endproc procedure DrawAttractionPoint(x,y,e,r,g,b) rem If e=0 use r,g,b for color, 1 use color of nearby point, =2 contrasting color. rem proc DBGwrite 500,20," " rem write " DrawAP atts=",atts," atti=",atti," attX/Y=",attX[0],",",attY[0]," ",attX[1],",",attY[1]," ",attX[2],",",attY[2]," " rem write " x=",x," y=",y," e=",e x2=x+1 if x2>=windowW then x2=x-1 ary[]=pixel(x2,y) if e=1 rem write " x2=",x2," ary[0]=",ary[0]," ary[1]=",ary[1]," ary[2]=",ary[2] set color ary[0],ary[1],ary[2] elseif e=2 proc ContrastColor ary[0],ary[1],ary[2],254 else set color r,g,b endif draw line x-4,y-4,x+4,y+4 draw line x-4,y+4,x+4,y-4 redraw rem wait keydown endproc procedure ContrastColor(r,g,b,a) r=(r+128)%254 g=(g+128)%254 b=(b+128)%254 set color r,g,b,a endproc procedure DBGwrite(w,h,t$) set color 0,0,0 draw rect 0,0,w,h,1 set caret 0,0 set color 254,254,254 write t proc DrawStatusLines endproc procedure MotionModBox() rem Get box to project herd position into for more frequent sighting. set caret 0,20 w=(herdR-herdL)*sX motW=windowW+w h=(herdB-herdT)*sY motH=windowH+h rem This means as soon as herd is all left of window, its ready to (apparently) enter from right. motL=-w/2 rem This means as soon as herd is all above window, its ready to (apparently) enter from under. motT=-h/2 rem Now expand according to freedom, with freedom=100 meaning 1 window size. fw=(windowW*freedom)/100 motW=motW+fw motL=motL-fw/2 fh=(windowH*freedom)/100 motH=motH+fh motT=motT-fh/2 rem set color 254,254,254 rem write "MMB herdR="+str$(herdR)+" herdL="+str$(herdL)+" w="+str$(w)+" motW="+str$(motW)+" motL="+str$(motL) rem write "MMB herdT="+str$(herdT)+" herdB="+str$(herdB)+" h="+str$(h)+" motH="+str$(motH)+" motT="+str$(motT) rem wait keydown endproc procedure MoveCentre() rem Plan: if its moving to the 4th, so long as its nearer the 3rd than the 4th, it keeps going to the 4th. rem As soon as its nearer the 4th than the 3rd, it starts moving to the 5th. Hope it works. rem Get info re next and prev attraction point. previ=(atts+wix-1)%atts nexti=(atts+1)%atts prevX=attX[previ] prevY=attY[previ] targX=attX[wix] targY=attY[wix] rem dv prev, dt next, not calculus. dvx=posX-prevX dvy=posY-prevY dv=dvx*dvx+dvy*dvy dtx=posX-targX dty=posY-targY dt=dtx*dtx+dty*dty if dv>dt rem Closer to target than prev, make next the targ. wix=nexti targX=attX[wix] targY=attY[wix] dtx=posX-targX dty=posY-targY dt=dtx*dtx+dty*dty endif if decel>0 speed=velX*velX+velY*velY if speed>rnd(100) rem Using numbers like 100/150 makes tuning easier. velX=(velX*100)/150 velY=(velY*100)/150 endif else rem Inverse probability of acceleration, sort of. if abs(dtx)>rnd(dt+1) rem Accel x to targX. if dtx<0 velX=velX+1 else velX=velX-1 endif endif if abs(dty)>rnd(dt+1) rem Accel y to targY. if dty<0 velY=velY+1 else velY=velY-1 endif endif endif posX=posX+velX posY=posY+velY if velX=0 and rnd(1000)<10 then velX=velX+rnd(3)-1 if velY=0 and rnd(1000)<10 then velY=velY+rnd(3)-1 rem Set mousedown as thats where ShowTheLot places the lines centre. proc ShowInModulusWindow posX,posY endproc procedure Teleport() teleportF=1 proc DrawStatusLines redraw rem Wait for mousedown and set target to mouse point. m=0 do wait 10 m=mousebutton(0) if m>0 posX=mousex() posY=mousey() break endif loop rem proc HereBoyLoop proc ShowInModulusWindow posX,posY do wait 10 rem if mousebutton(0)>0 then break m=mousebutton(0) ky=inkey() c$=chr$(ky) c=lower$(c) exit=MotionKeyEdit(ky,c) if exit>0 then break rem Needs recalc if scaled or generated. if c="s" or c="g" then proc MotionModBox if m>0 then proc HereBoyMouseDown proc ShowInModulusWindow posX,posY if m>0 then break loop teleportF=0 proc DrawStatusLines redraw endproc procedure HereBoy() runRoundF=0 fromFarTargX=windowCX fromFarTargY=windowCY proc HereBoy2 proc DrawStatusLines redraw endproc procedure RunRound() runRoundF=1 proc DrawStatusLines redraw rem Wait for mousedown and set target to mouse point. m=0 do wait 10 m=mousebutton(0) if m>0 fromFarTargX=mousex() fromFarTargY=mousey() break endif loop proc HereBoy2 runRoundF=0 proc DrawStatusLines redraw endproc procedure HereBoy2() hereBoyF=1 fromFarF=0 rem proc DBGwrite 500,20," " rem write " HereBoy a posX=",posX," posY=",posY rem redraw rem wait keydown if inMotionF<=0 proc MotionAndHereBoyInit endif rem Get distance, if too far to build arrays, home in as fast as consistently possible, roughly. rem TODO for DBG, MUST REMOVE!! rem posX=300 rem posY=20000 rem dx=windowCX-posX dx=fromFarTargX-posX rem dy=windowCY-posY dy=fromFarTargY-posY d2=dx*dx+dy*dy df#=sqr#(float#(d2)) d=int(df) diag=int(sqr#(float#(windowW*windowW+windowH*windowH))) if d>10000 or d>diag*10 or runRoundF>0 then proc NearHomeFromFar dx,dy,d2,df,diag if runRoundF<=0 then proc DecelAndStop rem proc DBGwrite 500,20," " rem write " HereBoy b posX=",posX," posY=",posY rem redraw rem wait keydown proc HereBoyLoop hereBoyF=0 endproc procedure HereBoyLoop() do wait 10 rem if mousebutton(0)>0 then break m=mousebutton(0) ky=inkey() c$=chr$(ky) c=lower$(c) exit=MotionKeyEdit(ky,c) if exit>0 then break rem Needs recalc if scaled or generated. if c="s" or c="g" then proc MotionModBox if m>0 then proc HereBoyMouseDown proc ShowInModulusWindow posX,posY loop endproc procedure NearHomeFromFar(dx,dy,d2,df#,diag) recurCt=0 fromFarF=1 rem Because NearHomeFromFarRec can recur, it sets this when it breaks and check it after self calls. fromFarFBreak=0 proc NearHomeFromFarRec dx,dy,d2,df,diag fromFarF=0 endproc procedure NearHomeFromFarRec(dx,dy,d2,df#,diag) rem dx=windowCX-posX ; dy=windowCY-posY if recurCt>10 if recurCt=11 proc DBGwrite 1200,20,"recur 11" else set color 254,254,254 write recurCt endif endif if recurCt>100 posX=diag posY=diag velX=0 velY=0 return endif recurCt=recurCt+1 ct=0 aryX[]=CalcDecelPoint(posX,velX,dx,1) rem pX is periods until decel, decX is distance from home at decel point. pX=aryX[0] decX=aryX[1] aryY[]=CalcDecelPoint(posY,velY,dy,1) pY=aryY[0] decY=aryY[1] proc DBGwrite 1200,20,"" rem write "p",posX,",",posY," v",velX,velY," P",pX,",",pY write "P",pX,",",pY rem wait keydown rem Flags for when decelerating. fax=0 fay=0 if pX<=0 then fax=1 if pY<=0 then fay=1 rem Acceleration. ax=0 if dx<>0 then ax=dx/abs(dx) ay=0 if dy<>0 then ay=dy/abs(dy) do if ct%3=2 then proc DBGwrite 1200,20,"" set color 254,254,254 write " ct",ct," p",posX,",",posY," v",velX,",",velY redraw ky=inkey() c$=chr$(ky) c=lower$(c) rem TODO encapse key stuff from Display to ReactToKeys. if ky>0 if c=" " or c="p" rem dummy=PauseFromFar() rem Break if unpaused with 'x'. Cant use FromFarBreakFunc as its too eager. ky=PauseFromFar() c$=chr$(ky) c=lower$(c) if c="x" then break else exit=MotionKeyEdit(ky,c) if exit>0 then break endif endif rem dx=windowCX-posX dx=fromFarTargX-posX rem dy=windowCY-posY dy=fromFarTargY-posY d2=dx*dx+dy*dy df#=sqr#(float#(d2)) d=int(df) vaX=abs(velX) vaY=abs(velY) rem if vaX<10 and vaY<10 and d0 then break if vaX<10 and vaY<10 and d0 then break if ct>=pX and (fax=0 or 9=ct%10) rem Check x acceleration ax=AccelFunc(dx,velX,1) fax=1 endif if ct>=pY and (fay=0 or 9=ct%10) rem Check y acceleration ay=AccelFunc(dy,velY,1) fay=1 endif if vaX<2 and vaY<2 if df>10000.0 or d>diag*10 if ct>10 rem Could be useful to recalc now its very slow and still far away. proc NearHomeFromFarRec dx,dy,d2,df,diag rem break if FromFarBreakFunc(ky,c)>0 then break endif else rem Near enough. rem break if FromFarBreakFunc(ky,c)>0 then break endif endif rem write " @p",posX,",",posY," v",velX,",",velY posX=posX+velX posY=posY+velY write " #p",posX,",",posY," v",velX,",",velY redraw rem wait keydown velX=velX+ax velY=velY+ay proc ShowInModulusWindow posX,posY ct=ct+1 loop endproc function FromFarBreakFunc(ky,c$) rem NearHomeFromFarRec is recursive, so need to set fromFarFBreak as well as return 1 if to break, rem and need to test it here. rem Also, when in 'run round' mode, should run round until stopped by a key press. Otherwise just break. rem eg if near, break so HereBoy can take over, but carry on if runRoundF set. if runRoundF>0 and fromFarFBreak<=0 wait 10 rem if inkey()>0 then return 1 if c="x" fromFarFBreak=1 return 1 endif else fromFarFBreak=1 return 1 endif return 0 endfunc function PauseFromFar() fromFarFP=1 proc DrawStatusLines redraw wait 500 do wait 10 if mousebutton(0)>0 then break ky=inkey() c$=chr$(ky) c=lower$(c) if c="x" or c=" " or c="p" fromFarFP=0 return ky else dummy=MotionKeyEdit(ky,c) rem Needs recalc if scaled or generated. if c="s" or c="g" then proc MotionModBox endif loop fromFarFP=0 return 0 endfunc function AccelFunc(d,v,a) rem Given distance, velocity and max accel, is rest at the distance got quickest by accel or decel? a=abs(a) if d>0 if v<=0 return a else rem Its going the right way but would it overshoot if max decel applied? if a*v*(v+1)/2>d rem Yes. return -a else return a endif endif else if v>0 return -a else v2=abs(v) rem Its going the right way but would it overshoot if max decel applied? if a*v2*(v2+1)/2>abs(d) rem Yes. return a else return -a endif endif endif endfunc function CalcDecelPoint[](p,v,d,a) rem p - position, v velocity, d displacement, max acceleration. rem eg p=-60, v=10, d=90, a=1. rem The fastest way to change from present p=-60 v-10, to wanted d=90 velocity 0, rem is to accel at max (absolute) a=1 or a=-1, for ap periods, then decel at max (absolute) rem for dp periods. The main problem is to find ap. rem rem Suppose v=0 (at start). Then in successive periods, the velocity is 0,1,2,3,..ap and the distance rem travelled is the area of the triangle, ap*(ap+1)/2. Decel is ap-1, ap-2,..0, area ap(ap-1)/2. rem Adding gives ap*(ap+1)/2 + ap(ap-1)/2 = ap/2 * (ap+1 +ap-1) = ap*ap. rem Since ap*ap = area = distance = abs(d), ap=root(abs(d)). rem BUT - generally v<>0. The problem is geometry (basically) - find the right isosceles triangle with a rem corner at 0 and a perpendicular from the base with height v at distance abs(d) from the corner at 0. rem EXCEPT there are cases where instant decel is required, (like the perp cutting between the corner- rem at-0 and the peak), and where overshoot is inevitable, with instant decel still the best option. rem Also could be initially moving the wrong way. rem Back to the MAIN CASE - area is as before minus a corner cut by a perp height v. rem d = area = ap*ap - v*(v+1)/2 rem ap = root (d+v*(v+1)/2) rem That's it, apart from details like sign, and ap being periods prior to hitting zero velocity. rem Start by reducing to v is right way (same sign as d), and d is always >=0. v2=v d2=d d2=abs(d) if v2<0 and d2<0 v2=abs(v) elseif v2>0 and d2<0 v2=-v endif rem Calc cutoff. rem TODO this assumes max abs(a)=1. cu=v2*(v2+1)/2 if cu>0 and v2<0 then cu=-cu apap=d2-cu if apap>0 rem ap is periods until decel, decDis is distance from target at decel point. ap=int(sqr#(float#(apap))) decDis=d2-(v2*ap+ap*ap/2) return [ap,decDis] endif if v2<0 rem decDis=(int(sqr#(float#(d2*2))+int(sqr#(float#(abs(v2)))))/2 rem decel straight away, so periods to decel =0, and distance decel point to target =d2. return [0,d2] endif rem Now v2>=0, d2>=0 and cu>=d2, means going right way but will overshoot. rem As above, periods to decel =0, and distance decel point to target =d2. return [0,d2] endfunc procedure HereBoyMouseDown() mx=mousex() my=mousey() rem First x,y 0,0 is ignored by top level of recursion in TwinkleSteps (cant see why). rem The second 0,0 gets drawn (with opposite color to previous) and is the centre of a cross rem with the other 4 coords for the arms. The line of crosses from mouse-down to lines centre rem shows where new drawing would be. turtX[]=[0,0,1,-2,1, 0] turtY[]=[0,0,0, 0,1,-2] rem op for NumberFromKeyPress. r is replace eg prev r (key 8) = 8. numFromKeyOp$="r" while mousebutton(0)>0 t0=time() mx=mousex() my=mousey() dx=mx-posX dy=my-posY d2=dx*dx+dy*dy df#=sqr#(float#(d2)) rem Number of points to draw at on the line posX,posY dx,dy. n=int(df/speedHB)+1 rem eg d=30, speedHB=10 needs points 0 10 20 30. 30/10 +1 = 4. But 30/11 +1 = 3 and still needs 4 pts. So: if float#(n)*df1 for i=0 to n-1 proc ShowInModulusWindow HBxLatest[i],HByLatest[i] next posX=HBxLatest[n-1] posY=HByLatest[n-1] velX=HBxLatest[n-1]-HBxLatest[n-2] velY=HByLatest[n-1]-HByLatest[n-2] else posX=mx posY=my proc ShowInModulusWindow posX,posY endif endproc function NumberFromKeyPress(ky,c$,n) digin=0 rem Test if digit 0-9 pressed. if ky>=a0 and ky<=a9 then digin=1 if digin>0 dig=ky-a0 op$=numFromKeyOp if op="r" return dig elseif op="x" return n*dig elseif op="/" if dig<>0 then return n/dig return n elseif op="+" return n+dig elseif op="-" return n-dig endif else rem Cursor keys inc, dec, double, half. if ky=39 then return n+1 if ky=37 then return n-1 if ky=38 then return n+n if ky=40 then return n/2 rem If key matches, set op (times, divide, replace, plus, minus). if c="x" or c="/" or c="r" then numFromKeyOp=c if c="+" or c="=" then numFromKeyOp="+" if c="-" or c="_" then numFromKeyOp="-" endif return n endfunc procedure TwinkleSteps(n,x1,y1,x2,y2,dx,dy,t0,rec,&turtX[],&turtY[]) rem rec is the recursion counter. Recursion is used to get more than just 1 pixel per twinkle point. rem if rec>=sizeof(turtX) then return HBx[n] HBy[n] HBr[n] HBg[n] HBb[n] nf#=float#(n-1) dxf#=float#(dx) dyf#=float#(dy) for i=0 to n-1 rem Get coords, store in HBx/HBy, then replace with contrasting color. if i=0 x=x1 y=y1 elseif i=n-1 x=x2 y=y2 elseif n>1 rem Step HBx[i] from x1 to x2 x=x1+int(float#(i)*dxf/nf) y=y1+int(float#(i)*dyf/nf) endif HBx[i]=x HBy[i]=y rem Store RGB of pixel. ary[] ary[]=pixel(x,y) r=ary[0] g=ary[1] b=ary[2] HBr[i]=r HBg[i]=g HBb[i]=b rem Contrasting color. r=(r+128)%254 g=(g+128)%254 b=(b+128)%254 set color r,g,b rem ILLOGICAL! Setting color red resulted in GREY centre-pixels on any background). rem Without it there was a hole in the every cross, meaning top level hadnt drawn anything. rem if rec=0 then set color 254,0,0 rem if rec=0 then write " r",r," g",g," b",b," x",x," y",y draw pixel x,y next rem proc DBGwrite 1200,20," " rem set color 254,254,254 rem write " Twink a time-t0=",time()-t0," doing1=",doing1 rem write " Twink a rec=",rec if recrnd." rem Using numbers like 100/150 makes tuning easier. velX=(velX*100)/150 velY=(velY*100)/150 speed=velX*velX+velY*velY endif posX=posX+velX posY=posY+velY proc ShowInModulusWindow posX,posY wend rem write " Exit DecelAS" redraw endproc procedure ShowInModulusWindow(x,y) x2=ShiftedModulus(x,motL,motW) rem set color 254,254,254 rem write "SIMW x2="+str$(x2)+" x="+str$(x)+" motL="+str$(motL)+" motW="+str$(motW) rem wait keydown y2=ShiftedModulus(y,motT,motH) mouseDownX=x2 mouseDownY=y2 proc ShowTheLot endproc function ShiftedModulus(x,a,w) rem Keep x in interval a<=xa rem eg a=15, w=5, x=53. d=abs(x-a) = abs(53-15) = 38, r=d%w = 38%5 = 3, return 15+3 = 18. return a+r else rem eg a=-15, w=5, x=-16. d=abs(x-a) = abs(-16+15) = 1, r=d%w = 1%5 = 1. return s=a+w-r = -15+5-1 = -11. rem eg a=-15, w=5, x=-26. d=abs(x-a) = abs(-26+15) = 11, r=d%w = 11%5 = 1. ret s=a+w-r = -15+5-1 = -11. return a+w-r endif endfunc procedure DrawStatusLinesOLD(r) rem If r>0 then its random so it flashes. rem TODO flickerer, inMotionF, inMotionF paused, hereBoyF, hereBoyF paused, runRoundF, rem runRound paused, fromFarF, fromFar paused. set color 0,0,0 rem draw line 0,1,24,1 draw rect 0,0,24,3,1 if rnd(100)<50 or r<=0 if inMotionF>0 set color 254,254,254 rem draw line 0,1,3,1 draw rect 0,0,4,3,1 if hereBoyF>0 set color 254,254,0 rem draw line 0,1,3,1 draw rect 0,0,4,3,1 endif if runRoundF>0 set color 254,64,64 rem draw line 8,1,11,1 draw rect 8,0,4,3,1 endif if fromFarF>0 and hereBoyF>0 set color 64,64,254 rem draw line 16,1,20,1 draw rect 16,0,4,3,1 endif endif endif endproc procedure DrawStatusLines() rem TODO flickerer, inMotionF, inMotionF paused, hereBoyF, hereBoyF paused, runRoundF, rem runRound paused, fromFarF, fromFar paused. new inMotionFP, hereBoyFP, runRoundFP, fromFarFP. rem Remember NearHomeFromFar is recursive. Others MIGHT get recursive, if code ability to alternate rem HereBoy / RunRound (at pres, RunRound exits to HereBoy). set color 0,0,0 draw rect 0,0,60,3,1 if inMotionF>0 set color 254,254,254 if rnd(100)<50 rem Flickerer. draw rect 0,0,4,3,1 endif draw rect 7,0,4,3,1 if inMotionFP>0 set color 254,64,64 draw rect 14,0,4,3,1 endif if hereBoyF>0 set color 64,254,64 draw rect 21,0,4,3,1 endif if hereBoyFP>0 set color 254,64,64 draw rect 28,0,4,3,1 endif if runRoundF>0 set color 254,254,64 draw rect 35,0,4,3,1 endif if runRoundFP>0 set color 254,64,64 draw rect 42,0,4,3,1 endif if fromFarF>0 and hereBoyF>0 set color 64,64,254 draw rect 49,0,4,3,1 endif if fromFarFP>0 and hereBoyF>0 set color 254,64,64 draw rect 56,0,4,3,1 endif endif endproc procedure ShowTheLot() rem To show at centre when lines centre is centreX,centreY. rem wc=windowCX rem hc=windowCY rem After mag, lines centre is centreX*sX,centreY*sY. rem To put in centre of window, need: rem oX=wc-centreX*sX rem oY=hc-centreY*sY rem To centre next lot of lines on last mousedown point. oX=mouseDownX-centreX*sX oY=mouseDownY-centreY*sY rem clearPeriod if clearCount=0 set color backR,backG,backB,backAlpha cls endif clearCount=(clearCount+1)%clearPeriod proc DrawStatusLines a=max(0,lineAlpha+alphaPlus) a=min(254,a) if colorMode=2 for i=0 to nLines-1 c=rnd(numColors) set color colR[c],colG[c],colB[c],a draw line oX+X1[i]*sX, oY+Y1[i]*sY, oX+X2[i]*sX, oY+Y2[i]*sY next elseif colorMode=3 and cycles>0 and numColors>0 cycLen=max(1,nLines/cycles) proc LinesCyclingColors a else set color lineR,lineG,lineB,a for i=0 to nLines-1 draw line oX+X1[i]*sX, oY+Y1[i]*sY, oX+X2[i]*sX, oY+Y2[i]*sY next endif redraw endproc procedure LinesCyclingColors(a) s=0 lpc=max(1,cycLen/numColors) rem set caret 0,200 rem set color 254,254,0 rem wln " lpc="+str$(lpc)+" s="+str$(s)+" nLines="+str$(nLines) rem redraw while s0 rem set color 254,254,0 rem wln " lpc2="+str$(lpc2)+" s="+str$(s)+" e="+str$(e) rem redraw for i=s to e j=i-s k=ep1-i rem Weight the color channels more towards r2,g2,b2 as i increases. r=(r1*j+r2*k)/lpc2 g=(g1*j+g2*k)/lpc2 b=(b1*j+b2*k)/lpc2 rem set color 254,254,0 rem write " j="+str$(j)+" k="+str$(k)+" lpc2="+str$(lpc2) rem write " r1="+str$(r1)+" g1="+str$(g1)+" b1="+str$(b1) rem write " r2="+str$(r2)+" g2="+str$(g2)+" b2="+str$(b2) rem write " r"+str$(r)+" g"+str$(g)+" b"+str$(b) rem wln rem redraw set color r,g,b,a draw line oX+X1[i]*sX, oY+Y1[i]*sY, oX+X2[i]*sX, oY+Y2[i]*sY next rem else rem set color 254,254,254 rem set caret 10,20 rem write "LinesCyclingColors lpc2 =",lpc2 endif s=e+1 wend endproc procedure ShowWithCurrentColor() rem To centre lines on last mousedown point. oX=mouseDownX-centreX*sX oY=mouseDownY-centreY*sY for i=0 to nLines-1 draw line oX+X1[i]*sX, oY+Y1[i]*sY, oX+X2[i]*sX, oY+Y2[i]*sY next redraw endproc