$lib graph on
data 0,1 , 200,1 , 440,1 , 680,2 , 880,2 , 1040,1 , 1200,1
data 1360,0 , 1520,0 , 1720,0 , 1880,3 , 1960,3 , 2040,4
dim rowdata%(12 , 1) , co%(12) , maxy%(250) , palcols%(255) , bitpatt$(3)
dim huge harray?(600 , 600)
readfonts
pi = 3.141592653589
cls
pal% = 3 * 16     'starting palette set
for rowcount% = 0 to 12
	read rowdata%(rowcount% , 0)
	read rowdata%(rowcount% , 1)
next rowcount%
on timer (.3) gosub FlashHome
f$ = "heights2.dat"
if dir$(f$) = "" then
	f$ = "d:" + f$
	if dir$(f$) > "" then exit if
	sound 500 , 2
	color 12 + 16
	print "Height database missing"
	end
end if
open "b" , 1 , f$

'==========================================================

screen 12
line (140 , 170) - (500 , 230) , 10 , b
locate 12 , 20
if command$ > "" then centrelo$ = command$ else input; "Location    ",centrelo$
call LocationIn(centrelo$ , ecentre , ncentre)
print "  " + centrelo$
locate 13 , 20
input "Plot size, 20 - 300km    [100]  ",sqsize%
if sqsize% = 0 then sqsize% = 100
if sqsize% < 20 then sqsize% = 20
if sqsize% > 300 then sqsize% = 300

ehome = ecentre
nhome = ncentre

ecentre = .5 * int(ecentre * 2)
ncentre = .5 * int(ncentre * 2)
ecentre = 10 * (ecentre \ 10)
ncentre = 10 * (ncentre \ 10)

homex% = 2 * (ehome - ecentre) + sqsize%
homey% = 2 * (nhome - ncentre) + sqsize%

call ENtoNGR(ecentre , ncentre , centrelo$)
locate 14 , 30 : print "Extracting height data ..."
color 7
minh% = 9999
locate 16 , 1 : print string$(80 , 176);
color 3
for xcount% = 0 to sqsize% * 2 - 20 step 20
	locate 16 , 1 : print string$(xcount% / sqsize% * 40 , 219);
	for ycount% = 0 to sqsize% * 2 - 20 step 20
		e = ecentre + (xcount% - sqsize%) * .5
		n = ncentre + (ycount% - sqsize%) * .5       '20km square
		n100% = n \ 100
		e100% = e \ 100
		n10% = n \ 10 mod 10
		e10% = e \ 10 mod 10
		estart% = rowdata%(n100% , 1)
		filebreak& = rowdata%(n100% , 0) * 1000
		km100sq% = e100% - estart%
		km10sq% = n10% + e10% * 10
		offset10& = km100sq% * 40000  +  km10sq% * 400
		pointer& = offset10& + filebreak&
		seek 1 , pointer&
		get$ 1 , 400 , ch400$
		for g% = 0 to 399
			ch1$ = mid$(ch400$ , g% + 1 , 1)
			epoint% = g% mod 20
			npoint% = 19 - g% \ 20
			hm% = asc(ch1$)
			maxhm% = max(maxhm% , hm%)
			harray?(xcount% + epoint%, ycount% + npoint%) = hm%
			maxh% = max(maxh% , hm%)
			minh% = min(minh% , hm%)
		next g%
	next ycount%
next xcount%
locate 16 , 1 : print space$(80);
if maxh% = 0 then maxh% = 10
timer off

maximum = maxh% ^ 1.32
cls
reg 1 , 0
call interrupt &h33
ebase = ecentre
nbase = ncentre
baselo$ = centrelo$
gosub SetUpPalette
ChangePalette

pixel% = 200 / sqsize%
xhfactor = 50 / maxh%
scal = 180 / sqsize%
ortho = 50
sc = scal * sin(pi / 180 * ortho)
cc = scal * cos(pi / 180 * ortho)
colscale = 14 / (maxh% - minh%)

do
	line (445 , 420) - (550 , 448) , 15 , b
	line (446 , 421) - (549 , 447) , 1 , bf

	call TextXY(using$("###" , sqsize%) + "km square"	, 450 , 435 , 11 , 1 , 2)
	call TextXY("Centre " + ucase$(centrelo$), 450 , 445 , 11 , 1 , 1)

	locate 30 , 1
	call textxy("P" , 100 , 470 , 15 , 0 , 2)
	call textxy("alette" ,108 , 470 , 7 , 0 , 2)
	call textxy("M" , 172 , 470 , 15 , 0 , 2)
	call textxy("ap type" , 180 , 470 , 7 , 0 , 2)
	call textxy("O" , 250 , 470 , 15 , 0 , 2)
	call textxy("rthogonal angle" , 258 , 470 , 7 , 0 , 2)
	call textxy("H" , 400 , 470 , 15 , 0 , 2)
	call textxy("/ctrl-[H] height" , 408 , 470 , 7 , 0 , 2)


	timer off
	for ycount% = sqsize% * 2 - 1 to 0 step -1
		for xcount% = 0 to sqsize% * 2 - 1
			xh% = (harray?(xcount% , ycount%) ) * xhfactor    'plotted height stays compressed
			select case maptype%
			case 1
				x% = 320 + xcount% * cc - ycount%  * cc
				y% = 440 - xcount% * sc - ycount%  * sc - xh%
			case 0
				x% = xcount% * scal + sc * ycount%
				y% = 430 - ycount% * cc - xh%
			end select
			col% = (harray?(xcount% , ycount%) - minh%) * colscale + 1
			if col% = 1 and harray?(xcount% , ycount%) > 0 then col% = 2
			if xcount% > 0 then line - (x% , y%) , col%  else pset (x% , y%) , col%
			if xcount% = homex% and ycount% = homey% then
				homepx% = x%
				homepy% = y%
			end if
		next xcount%
	next ycount%
	scale

	line (3 , 13) - (105 , 44) , 15 , b
	line (4 , 14) - (104 , 43) , 2 , bf

	call TextXY("  '3DMAP'" , 5 , 30 , 13 , 2 , 3)
	call TextXY(" G4JNT  1997" , 5 , 40 , 13 , 2 , 2)

	timer on
	do
				ik$ = ucase$(inkey$)
		select case ik$
		case "P"
			changepalette
		case "M"
			maptype% = (maptype% + 1) mod 2
			ortho = 30
         sc = 170 / sqsize% * sin(pi / 180 * ortho)
			cc = 170 / sqsize% * cos(pi / 180 * ortho)
			cls
			exit loop
		case "H"
			xhfactor = xhfactor * 1.2
			cls
			exit loop
		case chr$(8)
			xhfactor = xhfactor / 1.2
			cls
			exit loop
		case "O"
			ortho = (ortho + 10) mod 90
         sc = 170 / sqsize% * sin(pi / 180 * ortho)
			cc = 170 / sqsize% * cos(pi / 180 * ortho)
			cls
			exit loop
		case chr$(15)
      	sc = 170 / sqsize% * sin(pi / 180 * ortho)
			cc = 170 / sqsize% * cos(pi / 180 * ortho)
			ortho = (ortho - 10) mod 90
			cls
			exit loop
		case chr$(0 , 59)
			call DumpVGAtoBMP("3DMAP")
		end select
	loop until ik$ = chr$(27)
loop until ik$ = chr$(27)
end

FlashHome:
	flash% = not flash%
	pset (homepx% , homepy%) , 15
	if flash% then
		circle (homepx% , homepy%) , 1 , 15
	else
		circle (homepx% , homepy%) , 1 , 0
	end if
return


Sub LocationIn(lo$ , e , n)
	lo$ = ucase$(lo$)
	q1$="AA00AA  "
	q2$="RR99XX99"
	q3$="HA000000"
	q4$="YZ999999"
	whichtype%=0:notloc%=0:notngr%=0:found%=0
	for chk%=1 to len(lo$)
		a$=mid$(lo$,chk%,1)
		if a$ < mid$(q1$,chk%,1) or a$ > mid$(q2$,chk%,1) then notloc%=-1
		if a$ < mid$(q3$,chk%,1) or a$ > mid$(q4$,chk%,1) then notngr%=-1
	next chk%
	if (notloc% and notngr%) or len(lo$) < 6 then
		found%=0
		OSITE$=lo$
		searchloop%=0
		close 3             ' In case
		open "i",3,"sites.dat"
		do
			incr searchloop%
			line input #3,readline$
			posn1%=instr(readline$,"~")
			posn2%=instr(posn1%+7,readline$,"~")
			sitename$=left$(readline$,posn1%-1)
			if posn2%=0 then
				stloc$=mid$(readline$,posn1%+1,8)
			else
				stloc$=mid$(readline$,posn1%+1,posn2%-posn1%-1)
			end if
			stloc$=ucase$(stloc$)
			if instr(stloc$,"~")>0 then stloc$=left$(stloc$,6)  ' 6 Digit loc stored
			b%=instr(ucase$(sitename$),osite$)
			IF B%>0 THEN
				found%=-1
				exit loop
			end if
			loop until eof(3)
		close 3
		if not found% and dir$("auxsites.dat") > "" then
			open "i",3,"auxsites.dat"
			searchloop% = 0
			do
				incr searchloop%
				line input #3,readline$
				posn1%=instr(readline$,"~")
				posn2%=instr(posn1%+7,readline$,"~")
					sitename$=left$(readline$,posn1%-1)
				if posn2%=0 then
					stloc$=mid$(readline$,posn1%+1,8)
				else
					stloc$=mid$(readline$,posn1%+1,posn2%-posn1%-1)
					posnhgt% = instr(posn2% , ucase$(readline$) , "H")
					if posnhgt% > 0 then mastheight = val(mid$(readline$ , posnhgt% + 1))_
								else mastheight = 0
				end if

				stloc$=ucase$(stloc$)
				if instr(stloc$,"~")>0 then stloc$=left$(stloc$,6)  ' 6 Digit loc stored
				b%=instr(ucase$(sitename$),osite$)
				IF B%>0 THEN
					found%=-1
					exit loop
				end if
			loop until eof(3)
		end if
		lo$ = stloc$
		if found%=0 then	sound 300,1 : end
	end if

	c6% = asc(mid$(lo$ , 6 , 1))
	c5% = asc(mid$(lo$ , 5 , 1))
	if c5% >= 48 and c5% <= 57 then
		HN%=VAL(MID$(lo$,6,3))
		HE%=VAL(MID$(lo$,3,3))
		T1%=ASC(MID$(lo$,1,1))-65:IF T1%>8 THEN T1%=T1%-1
		T2%=ASC(MID$(lo$,2,1))-65:IF T2%>8 THEN T2%=T2%-1
		E = 500 * (T1% MOD 5) + 100 * (T2% MOD 5) - 1000 + HE% / 10
		N = 1900 - 500 * (T1% \ 5) - 100 * (T2% \ 5) + HN% / 10
	else
		if len(lo$) <= 6 then lo$ = lo$ + "44"
		longd=20*(asc(mid$(lo$,1,1))-74)+2*(asc(mid$(lo$,3,1))-48)_
				+(asc(mid$(lo$,5,1))-65)/12_
				+(asc(mid$(lo$,7,1))-48)/120

		latd= 10*(asc(mid$(lo$,2,1))-74)+asc(mid$(lo$,4,1))-48_
				+(asc(mid$(lo$,6,1))-65)/24_
				+(asc(mid$(lo$,8,1))-48)/240

		DR = 180/3.141592654
		LATR = LATD / DR
		LO = LONGD / DR
		Y = SQR(1 - .00667054# * SIN(LATR) * SIN(LATR))
		N = -100 + 111.0793 * (LATD - 49)
		N = N - 31.947 * SIN((LATD - 49) / DR) * COS(LATR + 49 / DR) + .971 * (2 + LONGD) ^ 2 * SIN(LATR) * COS(LATR) / Y
		E = 400 + 111.2651 * (2 + LONGD) * COS(LATR) / Y
		E = E - .0056 * (2 + LONGD) ^ 3 * (COS(LATR)) ^ 3 * ((TAN(LATR)) ^ 2 - 1)
	end if
end sub


sub ENtoNGR(e,n,lo$)
	 e1% = e\100
	 n1% = n\100
	 c1%=83-5*(n1%\5)+(e1%\5)
	 if c1%=73 then c1%=72
	 eh%=(e1% mod 5)
	 nh%=(n1% mod 5)
	 c2%=(4-nh%)*5+eh%+65
	 IF c2%>72 then incr c2%
	 e2&=(e-e1%*100)*10
	 n2&=(n-n1%*100)*10
	 ce$=mid$(STR$(e2&),2)
	 cn$=mid$(STR$(n2&),2)
	 while len(ce$)<3
		ce$="0"+ce$
	 wend
	 while len(cn$)<3
		cn$="0"+cn$
	 wend
	 lo$=CHR$(C1%)+CHR$(C2%)+CE$+CN$
end sub

SetUpPalette:
	for i% = 0 to 15
		palette i% , i%
		r% = i% * 4 + 3
		g% = i% * 4 + 3
		b% = i% * 4 + 3
		reg 1 , &h1010
		reg 2 , i%
		reg 3 , 256 * g% + b%
		reg 4 , r% * 256
		call interrupt &h10
	next i%
return

sub ChangePalette
	shared default%() , pal% , invertcol%
	incr pal%
	pal% = pal% mod 4
	for co% = 1 to 15
		select case pal%
		case 1
			r% = co% * 4 + 3
			g% = co% * 4 + 3
			b% = co% * 4 + 3
		case 2
			if co% >= 8 then r% = (co% - 8) * 9
			if co% >= 2 then g% = min((co% - 2) * 6 , 63)
			if co% <= 5 then b% = co% * 10 else b% = max((10 - co%) * 10 , 0)
			if co% >= 12 then b% = (co% - 12) * 18
		case 3
			if co% > 6 then r% = min ((co% - 5) * 8 , 63) else r% = 0
			if co% > 2 then g% = min(co% * 8  , 63)
			if co% > 5 then g% = max((12 - co%) * 6 , 0)
			if co% > 13 then g% = min((co% - 13) * 32 , 63)
			b% = min(co% * 12  , 63)
			if co% > 3 then b% = max((7 - co%) * 5 , 0)
			if co% > 11 then b% = min((co% - 11) * 15 , 63)
		case 0
			if co% > 7 then g% = min ((co% - 6) * 8 , 63) else g% = 0
			if co% > 2 then r% = min(co% * 5  , 63)
			b% = min(co% * 12  , 63)
			if co% > 3 then b% = max((7 - co%) * 5 , 0)
			if co% > 11 then b% = min((co% - 11) * 15 , 63)
		end select
		reg 1 , &h1010
		reg 2 , co%
		reg 3 , 256 * g% + b%
		reg 4 , r% * 256
		call interrupt &h10
	next co%
	restore
end sub
sub scale
	shared maxh , minh , colscale
	for a% = 0 to 15
		h = (minh + a% / colscale) ^ 1.32
		line (628 , a% * 12 + 6) - (639 , a% * 12 + 18) , a% , bf
		call textxy(using$("####" , h) , 600 , a% * 12 + 17 , 15 , 0 , 1)
	next a%
end sub

sub textxy(text$ , x% , y% , colour% , background% , fontno%)
	shared bitpatt$()
	select case fontno%
	case 1 , 5 , 7                '7x5 font
		rowsperchar% = 8
		colsperchar% = 6
		arrayref% = 0
	case 2 , 8
		rowsperchar% = 8
		colsperchar% = 8
		arrayref% = 1
	case 3 , 14
		rowsperchar% = 14
		colsperchar% = 8
		arrayref% = 2
	case 4 , 16
		rowsperchar% = 16
		colsperchar% = 9
		arrayref% = 3
	end select

	for charcount% = 1 to len(text$)
		ch% = asc(mid$(text$ , charcount% , 1))
		xbase% = x% + colsperchar% * (charcount% - 1)
		for rw% = 0 to rowsperchar% - 1
			thisch% = asc(mid$(bitpatt$(arrayref%) , 1 + rw% + ch% * rowsperchar% , 1))
			for bitno% = 0 to colsperchar% - 1
				if bit(thisch% , colsperchar% - bitno% - 1) then
					pset (xbase% + bitno%  , y% + rw% - rowsperchar% ) , colour%
				else
					if background% >= 0 then pset (xbase% + bitno%  , y% + rw% - rowsperchar% ) , background%
				end if
			next bitno%
		next rw%
	next charcount%
end sub

sub ReadFonts
'dim bitpatt$(3)                    'make sure this is in main part
	shared bitpatt$()
	fino% = freefile
	open "b" , fino% , "allfonts"
	get$  fino% , 2048 , bitpatt$(0)
	get$  fino% , 2048 , bitpatt$(1)
	get$  fino% , 3584 , bitpatt$(2)
	get$  fino% , 4096 , bitpatt$(3)
	close fino%
end sub

sub DumpVGAToBmp (basename$)     'Palette table assumes EGA compatibility
	filename$ = dir$(basename$ + "???.bmp")
	n% = val(mid$(filename$ , 6, 3))
	do
		f$ = dir$
		n% = max(val(mid$(f$ , 6, 3)) , n%)
	loop until f$ = ""
	n$ = mid$(str$(min(n% + 1, 999)) , 2)
	do while len(n$) < 3
		n$ = "0" + n$
	loop
	f$ = basename$ + n$ + ".BMP"
	color 15
	locate 5 , 2 : print f$
	bwidth& = 640           'previously set by   PALETTE CO%,CO%
	bheight& = 480
	ColoursInTable& = 16
	BitsPerPixel% = 4        '1 / 4 / 8 / 24  only
	NPlanes% = 1             '1 only
	InfoSize& = 40

	ImageSize& = bwidth& * bheight& * BitsperPixel% / 8
	dataoffset& = 54 + ColoursInTable& * 4
	filesize& = dataoffset& + ImageSize&

	t = timer
	if instr(ucase$(f$) , ".BMP") = 0 then f$ = f$ + ".BMP"
	fi% = freefile
	open "b" , fi% , f$
	i1% = 0 : i2% = 0 : compression& = 0
	bm$ = "BM"
	put$ fi% , bm$
	put fi% , 2 , filesize&
	put fi% ,, i1%
	put fi% ,, i2%
	put fi% ,, DataOffset&
	put fi% ,, InfoSize&
	put fi% ,, bwidth&
	put fi% ,, bheight&
	put fi% ,, NPlanes%
	put fi% ,, BitsPerPixel%
	put fi% ,, compression&
	put fi% ,, ImageSize&
	put fi% ,, XPelsPerMetre&
	put fi% ,, YPelsPerMetre&
	put fi% ,, ColoursInTable&
	put fi% ,, ImportantColours&

	seek fi% , 54
	for rgb% = 0 to 15
		reg 1 , &h1015
		reg 2 , rgb%
		call interrupt &h10
		b% = (reg(3) mod 256) * 4
		g% = (reg(3) \ 256) * 4
		r% = (reg(4) \ 256) * 4
		pa$ = chr$(b%) + chr$(g%) + chr$(r%) + chr$(0)
		put$ fi% , pa$
	next rgb%

	seek fi% , dataoffset&         'data starts at bottom left of picture
	nibble% = 0
	for y% = bheight& - 1 to 0 step -1
		dat$ = ""
		for x% = 0 to bwidth& - 2 step 2
				d% = 16 * point (x% , y%) + point (x% + 1 , y%)
				dat$ = dat$ + chr$(d%)
		next x%
      put$ fi% , dat$
	next y%
	close fi%
	sound 1750 , 2
	locate 5 , 2 : print space$(12)
end sub
