dim bitpatt$(3)
readfonts
pi = 3.141592654
screen 12
if command$ = "" then
	locate 12 , 20
	input "Base Locator  ",baseloc$
else
	baseloc$ = command$
end if
locate 14 , 20
input "Maximum range     [rtn] = Full   ",dia
if dia = 0 then dia = 6371.29 * pi
if baseloc$ = "" then baseloc$ = "IO90"
baseloc$ = ucase$(baseloc$)
call LoctoLL(baseloc$ , baselatd , baselongd)
baselatr = baselatd / 180 * pi : baselongr = baselongd / 180 * pi

cls
locate 29 , 1 : print "Great circle map";
locate 30 , 1 : print "centred on locator ";baseloc$;
palette 1 , 8
call plot(dia)
reg 1 , 0
call interrupt &h33
reg 1 , 1
call interrupt &h33
while inkey$ <> chr$(27)
	reg 1 , 3
	call interrupt &h33
	x% = reg(3) - 320
	y% = 240 - reg(4)
	dist = sqr(x% * x% + y% * y%)
	if (dist * dia / 240) < 20000 then
		if (dist + x%) = 0 then th = 180 else_
				th = 360 / pi * atn(y% / (x% + dist))
		bearing = 90 - th
		if bearing < 0 then bearing = bearing + 360
		locate 29 , 64 : print using "Dist   ##### km  "; dist * dia / 240;
		locate 30 , 64 : print using "Bearing  ###ø    "; bearing;
	else
		locate 29 , 64 : print "                 ";
		locate 30 , 64 : print "                 ";
	end if
wend
end
'===========================================================================
sub LoctoLL(lc$ , latd , longd)
	longd=20*(asc(mid$(lc$,1,1))-74)
	latd= 10*(asc(mid$(LC$,2,1))-74)
	if len(lc$) > 2 then
		longd = longd + 2 * (asc(mid$(lc$ , 3 , 1)) - 48)
		latd = latd + asc(mid$(lc$ , 4 , 1)) - 48
	else
		longd = longd + 10
		latd = latd + 5
	end if

	if len(lc$) > 4 then
		longd = longd + (asc(mid$(lc$ , 5 , 1)) - 65) / 12 + .042
		latd = latd + (asc(mid$(lc$ , 6 , 1)) - 65) / 24 + .021
	else
		longd = longd + 1
		latd = latd + .5
	end if
end sub

sub plot (dia)
	shared pi , baselatr , baselongr
	dr= 180 / pi
	if dia >= 19000 then circle (320 , 240) , 240 , 2
	color 6
	locate 30 , 64 : print "Drawing axes     ";
	call axes
	circle (320 , 240) , 1 , 13
	open "b" , 1, "earth.dat"
	co% = 11
	locate 30 , 64 : print "Drawing coastline";
	color 7
	while not eof(1)
		get$ 1 , 2 , c$
		if c$ = "" or inkey$ = chr$(27) then exit loop
		longr = cvi(c$) / 10000
		get$ 1 , 2 , c$
		latr = cvi(c$) / 10000
		call CircleMap(latr , longr , x , y)
		px% = x / dia * 240 + 320
		py% = 240 - y / dia * 240
		if z% then
			pset (px% , py%) , co%
			z% = 0
		else
			if latr < (pi / 2) then
				line - (px% , py%) , co%
			else
				z% = -1
			end if
		end if
	wend
	close 1
	circle (320 , 240) , 1 , 12 : pset (0 , 0) , 12
	locate 30 , 64 : print "                 ";
end sub

sub CircleMap(latr , longr , x , y)
	shared baselatr , baselongr , pi
	csarc = sin(baselatr) * sin(latr) + cos(baselatr) * cos(latr) * cos((baselongr - longr))
	if abs(csarc) < 1 then arc = fnacs(csarc) else arc=0
	dist = abs(6371.29 * arc)
	if dist < .01 then bearing = 0 : backbearing = 0
	csbear = (sin(latr)-sin(baselatr) * cos(arc)) / (cos(baselatr) * sin(arc))
	if abs(csbear) > 1 then csbear = sgn(csbear)
	bearing = fnacs(csbear)
	if ((longr < baselongr) AND (longr > baselongr - pi )) OR (longr > baselongr + pi) then
		bearing = 2 * pi - bearing
	end if
	x = dist * sin(bearing)
	y = dist * cos(bearing)
end sub

sub axes
	shared pi, dia
	dr = 180 / pi
	if dia < 10000 then co% = 7 else co% = 8
	for longd = -180 to 160 step 20
		longr = longd / dr
		for latd = -90 to 90 step 1
			latr = latd / dr
			call CircleMap(latr , longr , x , y)
			px% = x / dia * 240 + 320
			py% = 240 - y / dia * 240
			pset (px% , py%) , co%
		next latd
	next longd

	for latd = -90 to 80 step 10
		latr = latd / dr
		for longd = -180 to 180 step 2
			longr = longd / dr
			call CircleMap(latr , longr , x , y)
			px% = x / dia * 240 + 320
			py% = 240 - y / dia * 240
			pset (px% , py%) , co%
		next longd
	next latd

	if dia < 10000 then
		for longd = -180 to 170 step 20
			for latd = -90 to 80 step 10
				sq$ = chr$(longd \ 20 + 74) + chr$(latd \ 10 + 74)
				call CircleMap((latd + 5) / dr , (longd + 10) / dr , x , y)
				px% = x / dia * 240 + 310
				py% = 244 - y / dia * 240
				call textxy(sq$ , px% , py% , 12 , -1 , 1)
			next latd
		next longd
	end if

end sub

DEF FNACS(X) = ATN((SQR(1 - X * X)) / X) + pi / 2 * (1 - SGN(X))

sub MakeLocator(lon , lat , locator$)
	locator$=chr$(65+int((lon+180)/20))+chr$(65+int((lat+90)/10))+_
	chr$(48+int((lon+180)/2 mod 10))+chr$(48+int((lat+90) mod 10))+_
	chr$(65+int((lon+180)*12 mod 24))+chr$(65+int((lat+90)*24 mod 24))+_
	chr$(48+int((lon+180)*120 mod 10))+chr$(48+int((lat+90)*240 mod 10))
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
