`SCROLL gosub is b/w the **************'s
` it grabs a bit of bitmap 2 made in DrawMap gosub
Rem * Title : hex func
Rem * Author : Yif
Rem * Date : 26-Jan-2002
rem Scroll large bitmap/range calculation
rem By Yif Jan 2002 (DB V102)
rem Set screen to new display mode
set display mode 800,600,16
sync on
rem Set font and the size of the new font
set text font "times new roman"
set text size 20
rem make array for variables for x & y positions of 1st & 2nd hexes
dim a(10)
mod=1 : click=0 : range=-1 : hexsinputed=0 : hex1$="" : hex2$=""
`______ setup hexgrid map
mapx=1942 : mapy=722 : create bitmap 1,mapx,mapy
create bitmap 2,mapx,mapy : mapchange=1 : gosub HexMap : gosub DrawHexMap
rem setup buttons
ink 11222222,0 : box 0,496,110,515 : box 0,520,110,538 : box 0,543,110,561
ink 16580607,1
text 6,498,"KeyBoard Input" : text 3,522," Zoom In " : text 3,544," Zoom Out "
text 340,470,"First hex" : text 323,490,"Second hex" :text 331,510,"RANGE = "
ink rgb(255,255,0),0 : text 0,462," Hex"
` _____________ Main loop ________________
do
mx=mousex() : my=mousey() : mc=mouseclick()
Gosub DrawHexMap
rem check if mouse over hex grid map
if my<455
hex$=hex(mx,my,sx,sy,mod)
rem grab hex data if mouse click, mc wont equal 1 until the 2nd go around the loop
gosub HexConvert
gosub RangeCalc
if mc=1 then repeat : until mouseclick()=0
endif
`________ check buttons if mouse "my" out of hex map zone
if my>456
gosub buttons
if KeyBdInput=1 then gosub RangeCalc : KeyBdInput=0
endif
`_______ clear inputed hex box then print new hex input value
ink 1,0 : box 35,458,230,478 : ink 16580607,1
if hex$="invalid Input" then hex$=""
text 36,462,hex$
ink 156789,0 : box 400,470,435,530 : ink 16580607,1
if hexsinputed=1
text 400,470,hex1$
` _____mouse moved inside HexMap so mouse "perliminary" 2nd hex & range shown
if my<455
text 400,490,hex2$
text 400,510,str$(range)
mapchange=1 : gosub RangelineDraw
endif
` ______1st hex input by mouse & then mouse moved outside HexMap persumably to enter
` ______2nd hex by keyboard "SO" mouse "perliminary" 2nd hex & range not shown
if my>456
if hex2$<>"" then hex2$="" : range=0 : mapchange=1
` if mapchange=1 then gosub RangelineDraw
gosub RangelineDraw
endif
endif
if hexsinputed=2
text 400,470,hex1$
text 400,490,hex2$
text 400,510,str$(range) : mapchange=1 : gosub RangelineDraw
endif
`_______ print variable on screen to check for problems while running program
gosub ShowCalcs
`________ shut down program
if controlkey()=1
undim a(10)
end
endif
ink 1,0
`_____ Update screen
sync
`___ End of loop
loop
`************************************************************************************
DrawHexMap:
rem SCROLL THE 2D MAP
rem Move offset with mouse position(when against the edges of the screen)
if mx=0 then sx=sx-10 : mapchange=1 : if sx<0 then sx=0
if my=0 then sy=sy-10 : mapchange=1 : if sy<0 then sy=0
if mx=799 then sx=sx+10 : mapchange=1 : if sx>mapx-800 then sx=mapx-800
if my=599 then sy=sy+10 : mapchange=1 : if sy>mapy-457 then sy=mapy-457
if upkey()=1 then sy=sy-5 : mapchange=1 : if sy<0 then sy=0
if downkey()=1 then sy=sy+5 : mapchange=1 : if sy>mapy-457 then sy=mapy-457
if leftkey()=1 then sx=sx-5 : mapchange=1 : if sx<0 then sx=0
if rightkey()=1 then sx=sx+5 : mapchange=1 : if sx>mapx-800 then sx=mapx-800
if mapchange=1
if hexsinputed=0
rem Copy region of (bitmap 2) to visible screen (bitmap 0)
copy bitmap 2,sx,sy,sx+799,sy+456,0,0,0,799,456
set current bitmap 0
mapchange=0
else
rem Copy region of (bitmap 2) to range line draw bitmap (bitmap 1)
copy bitmap 2,sx,sy,sx+799,sy+456,1,sx,sy,sx+799,sy+456
` copy bitmap 2,1
set current bitmap 0
endif
endif
return
`************************************************************************************
RangeCalc:
if hex$="invalid Input" then return
`________if starting new rangecalc then reset range
if hexsinputed=2
if (mc=1 OR KeyBdInput=1)
hex1$="" : hexsinputed=0
else
return
endif
endif
if hex1$=""
if (mc=1 OR KeyBdInput=1)
xhex1=xhex : yhex1=yhex : hex1$=hex$
` ______centre dot of hex a(1 or 3)= x coordinate, a(2 or 4)= y coordinate
a(3)=a(1) : a(4)=a(2)
hexsinputed=1
return
endif
else
xhex2=xhex : yhex2=yhex : hex2$=hex$
a(5)=a(1) : a(6)=a(2)
endif
`____CHECK SLOPE OF LINE FROM 1st TO 2nd HEX
`____same xhex of 1st & 2nd hex then range equals yhex difference only
if a(5)=a(3)
range=Abs(yhex2-yhex1)
else
slope=Abs(((a(6)-a(4))*10000)/(a(5)-a(3)))
range=Abs(xhex2-xhex1)
if slope>5833
` ______thus range = x2-x1 AND the y difference BEOND the STANDARD slope
` ______WHY DOES THIS Next Line WORK mathematicly? I dont know !
range=range+Abs((a(6)-a(4))/(72/mod))-Abs((a(5)-a(3))/(120/mod))
endif
endif
`_____ 1st & 2nd hexes inputed thus range is done, SO setup for new rangeCalc
if (mc=1 OR KeyBdInput=1) then hexsinputed=2
return
buttons:
if mx<120
if mc=1
if zoneclick(0,496,100,515)=2 then gosub KeyBd : return
if zoneclick(0,520,120,538)=2 then mod=mod+1 : mapchange=1
if zoneclick(0,533,110,561)=2 then mod=mod-1 : mapchange=1
hex1$="" : hex2$="" : hexsinputed=0 : for x=1 to 6: a(x)=0 : next x
gosub HexMap : gosub DrawHexMap
endif
endif
return
Keybd:
` _____KEYBOARD INPUT
set cursor 120,461 : ink 165080607,1
input "Input Hex ",hex$
ink 1,0 : gosub HexConvert
if hex$="invalid Input" then return
KeyBdInput=1
return
RangelineDraw:
rem draw line from 1st to 2nd hex that you are checking for range calculation
ink 16580607,1
if hexsinputed=0 then return
` if mapchange=0 then return
copy bitmap 2,1 : set current bitmap 1
if hexsinputed=1
` _____peliminary line + range if mouse over hexmap but 2nd hex not yet set
if my<456 then line a(3),a(4),mx+sx,my+sy
else
` ______2nd hex set so hex1 to hex2 range line drawn
line a(3),a(4),a(5),a(6)
endif
`______Copy region of (bitmap 1) to visible screen (bitmap 0)
copy bitmap 1,sx,sy,sx+799,sy+456,0,0,0,799,456
set current bitmap 0
mapchange=0
return
function hex(mx,my,sx,sy,mod)
`______convert screen x,y to hex value, the"A" hexes equal xhex 0
`______white ink 16580607,1 :, IT SEEMS functions variables REMAIN in memory
`______even when program is outside function ???
doublecheck=0 : mymod=0 : x=0
`______xhex = xhexCheck when mx half way in b/w hexes such that depending on
`______"my" value, xhex can't be calculated from ONLY mx+sx
xhex=int(((mx+sx)/(20/mod)+1)/3) : xhexCheck=int(((mx+sx)/(20/mod)-1)/3)
if mod=3
xhex=int((((mx+sx)*3)/20+1)/3) : xhexCheck=int((((mx+sx)*3)/20-1)/3)
endif
`______mx+sx<20 not covered by xhex = xhexCheck (both = 0 )
if xhex=xhexCheck or (mx+sx)<(40/mod)
` ______ (mx+sx)<20 is o.k. even if xhex=xhexCheck=0
if (mx+sx)>(20/mod) then doublecheck=1
endif
`______ odd & even numbered hexes(A=0,B=1,C=2,...) have different "my" values
if xhex<>int(xhex/2)*2 then mymod=36/mod
yhex=int((my+sy-mymod)/(72/mod))+1 : if (my+sy)<mymod then yhex=0
`______ now check gray area b/w hexes, x1 & y1 is point of vertix of hex
`______ compare mouse position with vertix
`______ must first still compute old xhex & yhex above to get x1 & y1 correct
`______ before checking them
if doublecheck=1
x1=xhex*(60/mod)+40/mod : if mod=3 then x1=xhex*(60/mod)+14
y1=yhex*(72/mod) : if mymod=0 then y1=y1-36/mod
rem slope of hex side is 7/4=1.75 thus if abs of slope>1(i.e.=2)
rem then mouse is in the next hex. If screen resolution is
rem changed then slope may need to be change/checked
if abs((my+sy-y1)/(mx+sx-x1))>1 then xhex=xhex+1
mymod=0 : if xhex<>int(xhex/2)*2 then mymod=36/mod
yhex=int((my+sy-mymod)/(72/mod))+1 : if (my+sy)<mymod then yhex=0
endif
hex$=Chr$(xhex+65)+str$(yhex)
if xhex>25
hex$=Chr$(xhex+39)+Chr$(xhex+39)+str$(yhex)
rem mouse over next board
rem NEED TO CUT MORE CODE FOR THIS !
if xhex>32 then hex$=Chr$(xhex+32)+str$(yhex)
endif
endfunction hex$
HexConvert:
ok=0 : mymod=0
len=len(hex$)
` input range from "A1" to "GG10" so len from 2 to 4 charters
if len<2 or len>4 then hex$="invalid Input" : return
rem make all letters in hex$ upper case
hex$=upper$(hex$)
rem check first charter is A to Z
if TestInput(hex$,1,65,90)=0 then hex$="invalid Input" : return
rem check last charter is a number
if TestInput(hex$,len,48,57)=0 then hex$="invalid Input" : return
xhex=Asc(Left$(hex$,1))-65 : yhex=val(Right$(hex$,1))
if len=2
rem only B0, D0, etc no A0, C0
if xhex=int(xhex/2)*2
if TestInput(hex$,len,48,48)=1
` 1 meaning hex "letter"0 as in A0, C0, E0, ...
hex$="invalid Input" : return
endif
endif
endif
rem check for, i.e. "A10" or "AA1", etc
if len=3
rem putting two TestInput() calls on same line (if TInput and TInput)
rem doesn't work meaning a software bug(V102) or what ???
if TestInput(hex$,2,49,49)=1
if TestInput(hex$,3,48,48)=1
ok=1 : yhex=10
endif
endif
if left$(hex$,1)=mid$(hex$,2)
if TestInput(hex$,1,65,71)=0 then hex$="invalid Input" : return
xhex=xhex+26 : ok=1
endif
if ok=0 then hex$="invalid Input" : return
endif
rem check for, i.e. "AA10", etc
if len=4
if TestInput(hex$,1,65,71)=0 then hex$="invalid Input" : return
if left$(hex$,1)<>mid$(hex$,2) then hex$="invalid Input" : return
if right$(hex$,2)="10"
yhex=10 : xhex=xhex+26
else
hex$="invalid Input" : return
endif
endif
rem a(1) is x position of centre dot of hex for range calc,drawing units,etc
mymod=0 : if xhex<>int(xhex/2)*2 then mymod=36/mod
a(1)=xhex*60/mod : a(2)=yhex*72/mod+mymod-(36/mod)
return
function TestInput(hex$,pos,min,max)
test=1
` __ CHECK HEX INPUT TO SEE IF IT'S VALID
` hex$ is hex, pos is location on hex string, min & max are ASC numbers
if Asc(Mid$(hex$,pos))<min or Asc(Mid$(hex$,pos))>max then test=0
endfunction test
HexMap:
rem Create big hexgrid map, held in bitmap 2
rem limit scale of hexes resizing
if mod<1 then mod=1 : return
if mod>3 then mod=3 : return
a=0 : set current bitmap 2
ink 1,rgb(0,120,0) : cls
rem draw lines to show size of board, draw hex marking scem
ink 1,0 : line 1920/mod,0,1920/mod,2800/mod : line 3840/mod,0,3840/mod,2800/mod
if mod>1
line 0,720/mod,3840/mod,720/mod : line 0,1440/mod,3840/mod,1440/mod
endif
rem draw hex grid
for x=0 to 25*mod
b=36/mod
for y=0 to 21*mod
ink rgb(244,244,232),0 : dot a+60/mod,0 : dot a,b : dot a+60/mod,b+36/mod
ink 1,0 : line a-20/mod,b-36/mod,a+20/mod,b-36/mod
line a+20/mod,b-36/mod,a+40/mod,b : line a+20/mod,b+36/mod,a+40/mod,b
line a+20/mod,b+36/mod,a-20/mod,b+36/mod : line a-20/mod,b+36/mod,a-40/mod,b
line a-40/mod,b,a-20/mod,b-36/mod : line a+40/mod,b,a+80/mod,b
b=b+72/mod
next y
a=a+120/mod
next x
set text size 18 : if mod>1 then set text size 12
ink 20704607,1 : text 0,0,"A1"
for x=66 to 90 : text ((x-65)*60-10)/mod,0,Chr$(x) : next x
for x=65 to 71 : text ((x-39)*60-18)/mod,0,Chr$(x)+Chr$(x) : next x
if mod>1
ink rgb(0,120,0),0 : box 1903/mod,2,1938/mod,27/mod : ink 20704607,1 : text 1926/mod,0,"A"
for x=66 to 90 : text ((x-33)*60-10)/mod,0,Chr$(x) : next x
for x=65 to 71 : text ((x-7)*60-21)/mod,0,Chr$(x)+Chr$(x) : next x
endif
rem print numbers 1 to 10 down a few hex colums
for y=0 to 1200 step 600
for x=49 to 57 : text y/mod,(x-49)*72/mod,Chr$(x) : next x
text y/mod,650/mod,Chr$(49)+Chr$(48)
next y
set current bitmap 0 : set text size 18
return
rem Elegant Zone Check Function
function zoneclick(x1,y1,x2,y2)
click=0
if mousex()>x1 and mousex()<x2
if mousey()>y1 and mousey()<y2
` value of 1 for location check, not used in KeyboardInput
click=1
if mouseclick()=1 then click=2
endif
endif
endfunction click
ShowCalcs:
text 30,52,"xhex , yhex = "+str$(xhex)+" "+str$(yhex)
text 30,72,"mx , x1 = "+str$(mx)+" "+str$(a(7))
text 30,92,"a(1) , a(2) = "+str$(a(1))+" "+str$(a(2))
text 30,112,"a(3)-sx, a(4)-sy = "+str$(a(3)-sx)+" "+str$(a(4)-sy)
text 30,132,"a(5)-sx , a(6)-sy = "+str$(a(5)-sx)+" "+str$(a(6)-sy)
text 30,152," mapchange , hexsinputed = "+str$(mapchange)+" "+str$(hexsinputed)
` text 30,172,"rangecheck$ , my = "+str$(rangecheck$)+" "+str$(my)
` text 30,172,"int((my+sy-mymod)/(70/mod)) , mymod = "+str$(int((my+sy-mymod)/(56/mod)))+" "+str$(mymod)
` text 15,42,"mc , t1 ="+str$(mc)+" "+str$(t1)
` text 30,40," difx="+str$(difx)
` text 30,50,"mymod="+str$(mymod)
` text 30,60,"xhex="+str$(xhex) : text 130,60," yhex="+str$(yhex)
` text 30,70,"xhexCheck="+str$(int(((mx+sx)/(16/mod)-1)/3))
` text 30,80," x1,y1="+str$(x1)+" "+str$(y1)
` if difx=1
` text 30,92,"mx, my = "+str$(mx)+" "+str$(my)
` text 30,116," abs((my+sy-y1)/(mx+sx-x1))="+str$(abs((my+sy-y1)/(mx+sx-x1)))
` rem Prompt user
` ink rgb(255,255,0),0
` text 15,20,"Move mouse to scroll visible region"
return