# PISC pl/0+ Super Star Trek

const false = 0, true = 65535,
		cosmos = 1234,
		emax = 3000,
		smax = 1000,
		tmax = 10,
		defmax = 300,
		startdate = 39010,

		sys_life		= 0,
		sys_warp		= 1,
		sys_shield	= 2,
		sys_srs		= 3,
		sys_lrs		= 4,
		sys_phasers	= 5,
		sys_photon	= 6,
		sys_damage	= 7;

var a,b,c,
    s3,b3,k3,
    energy,shield,shldset,torp,		#Energy, Shields, Shield set point & Torpedos
	 docked,
    s9,b9,k9,
	 q1,s1,						#Enterprise Quadrant & Sector
    sdate, idate,				#Stardate, Starhour & Invasion Date
    galaxy[100],galmap[100],seed[100],sect[100],
	 system[8],damage[8],p,
	 klingon[27],
	 navdir[11],navdat[20],
	 distance,
	 ch,rnd,forever,
	 i,j,x,y;

procedure bigbang;

var i,r1,r2,s3,b3,k3;

begin

  randomize := cosmos;

  # Place Deep Space Navigation Borders

  # Border across top
  i := 0;
  while i < 10 do
  begin
     galaxy[i] := -1;
     galmap[i] := -1;	
     seed[i]   := -1;
     sect[i]   := -1;	
     i := i + 1;
  end;

  # Border across bottom
  i := 90;
  while i < 99 do
  begin
     galaxy[i] := -1;
     galmap[i] := -1;	
     seed[i]   := -1;
     sect[i]   := -1;	
     i := i + 1;
  end;

  # Borders down both sides
  i := 10;
  while i < 100 do
  begin
     galaxy[i]   := -1;
     galaxy[i+9] := -1;
     galmap[i]   := -1;	
     galmap[i+9] := -1;	
     seed[i]     := -1;
     seed[i+9]   := -1;
     sect[i]     := -1;	
     sect[i+9]   := -1;
     i := i + 10;
  end;

	# Place Stars in Galaxy	
  s9 := 0;
  i := 11;
  while i < 100 do
  begin
	if galaxy[i] = -1 then
	begin
	   i := i + 1;
	   continue;
	end;
	r1 := random;
	r2 := r1/6553;						# Should approximate a number between 0 and 10
	if r2 = 0 then r2 := r2 + 1;	# Minimum of one star per quadrant
	s3 := r2*100;						# Stars in the 100's place
	galaxy[i] := s3;
	s9 := s9 + r2;
	i := i + 1;
  end;

	#Create Quadrant random seeds
  i := 0;
  while i < 100 do
  begin
	if seed[i] = -1 then
	begin
	   i := i + 1;
	   continue;
	end;
	r1 := random;
	seed[i] := r1;		# Quadrant random number generator seed
	i := i + 1;
  end;

  #Game randomization for Star Bases and Klingons different from Cosmos for Stars
  randomize := 1235;

# Number of Star Bases in Galaxy
# Place Star Bases in Galaxy
  
  r1 := random;	
  r2 := r1/6553;		# Should approximate a number between 0 and 10
  b9 := r2/2;			# Total number of Star Bases
  if b9 = 0 then b9 := 1;	# Minimum of at least one Star Base per game

  b3 := b9;
  i := 22;
  while b3 > 0 do
  begin
	if galaxy[i] = -1 then
	begin
	   i := i + 1;
	   continue;
	end;
	r1 := random;	
	r2 := r1/655;				# Should approximate a number between 0 and 100 (%)
	if r2 > 90 then
        begin
           galaxy[i] := galaxy[i] + 10;	# Star Bases in the 10's position
	   b3 := b3 - 1;
	end;
	i := i + 1;
  end;


# Number of Klingon's in Galaxy
# Place Klingon's in Galaxy
  k9 := 0;
  i := 11;
  while i < 99 do
  begin
	if galaxy[i] = -1 then
	begin
	   i := i + 1;
	   continue;
	end;
	r1 := random;	
	r2 := r1/24845;	# Should approximate a number between 0 and 3
	k3 := r2;		# Klingons in the 1's (units) place
	galaxy[i] := galaxy[i] + k3;
	k9 := k9 + k3;
	i := i + 1;
  end;

  r1 := random;			# Number of game days before Klingon mass invasion attack
  r2 := r1/655;			# Should approximate a number between 0 and 100
  idate := sdate + (r2 * 2);		

end;


procedure galaxymap;
var a,i,j;
begin

  #parameters x,y;

  write "Galaxy Map";

	i := 0;
	while i < 100 do
	begin
		a := galmap[i];
		if a != -1 then write galmap[i],"\t";;
   	j := (i + 1) mod 10;
   	if j = 0 then write "\n";	
  		i := i + 1;
  	end;
  
	#result := z;

end;

procedure sitrep;
begin

	write "Star Date: ",sdate%u;
	write "Invasion date: ",idate%u;
	write "Days remaining: ",idate - sdate;
	write "There are",s9," stars in the galaxy.";
	write "There are",b9," Star Bases in the galaxy.";
	write "There are",k9," Klingon Battle Cruisers in the galaxy.";
	write "There are",energy," Energy units available.";
	write "Quadrant",q1/10,",",q1 mod 10;

end;

procedure putobj;
var i,j,r1,r2,loc,obj,num;
begin

  parameters obj,num;

  i := 0;
  while num > 0 do
  begin
	if i > 99 then i := 0;
	if sect[i] = -1 then
	begin
	   i := i + 1;
	   continue;
	end;
	if sect[i] != 0 then
	begin
	   i := i + 1;
	   continue;
	end;
	r1 := random;	
	r2 := r1/655;					# Should approximate a number between 0 and 100 (%)
	if r2 > 90 then
        begin
	   sect[i] := obj;			# Object value to place
	   result  := i;				# Returns the last assigned sector position
           num := num - 1;
	end;
	i := i + 1;
  end;

end;

procedure dump;
var i,j,p,txt[2];

begin
 
  parameters p;
	
  i := 0;
  while i < 100 do
  begin
     write p^,"\t";;
     j := (i + 1) mod 10;
     if j = 0 then write "\n";	
     i := i + 1;
     p := p + 1;	
  end;
	
	write "press [ENTER] to continue.";
	read txt$;
	
end;

procedure clearsector;
var i;
begin
	
	write "Clearing Sector";

	i := 0;
	while i < 100 do
	begin
	if sect[i] = -1 then
		begin
		   i := i + 1;
		   continue;
		end;
	sect[i] := 0;
	i := i + 1;	
	end;
	
end;

procedure setupklingons;
var i,j,
	 x,y;

begin

  parameters x;


#  write "Recording Enemy Klingon Positions";
#  write "Galaxy Quadrant ",x," = ",galaxy[x];

  i := 0;
  j := 0;
  while i < 100 do
	begin
   	if sect[i] = -1 then
   		begin
				i := i + 1;
				continue;
   		end;
     ch := sect[i];
     if ch = 'K' then begin
			#write "+K+ at location ",i;
			klingon[j*3] 	:= i;			# Location of this Klingon in sector
			klingon[j*3+1] := 500;		# Energy for this Klingon
			klingon[j*3+2] := 250;		# Shield for this Klingon
			j := j + 1;
	  end;
     i := i + 1;
  end;
		
end;

procedure setupsector;
var x,a,b,r1;
begin

	parameters x;

	write "Setup Sector";

	call clearsector; 

	r1 := seed[x];
	randomize := r1;

	a  := galaxy[x];
  	s3 := a / 100;
  	b  := s3 * 100;

  	write "Placing ",s3," stars.";
  	call putobj passing 42,s3;

  	a  := a - b;
  	b3 := a / 10;
  	b  := b3 * 10;

  	write "Placing ",b3," Star Bases.";
  	call putobj passing 33,b3;

	k3 := a - b;
  
  	write "Placing ",k3," Klingons.";
  	call putobj passing 75,k3;

  	write "Placing Enterprise.";
  	s1 := putobj passing 69,1;
 
  	call dump passing sect@;

	call setupklingons passing x;

end;


procedure srscan;
var a,b,i,j,ch,r1,r2,
    x,y,
    ctxt[4],shldpc;

begin

  parameters x;

  write "Short Range Scan";
  
  write "Galaxy Quadrant ",x," = ",galaxy[x];

  galmap[x] := galaxy[x];	# Update the players galaxy map with this Quadrant's current details
  
  ctxt$ := "GREEN";

	#write "Galaxy Map:"; call dump passing galmap@;
	
	if docked = true then ctxt$ := "DOCKED"
	else begin
		if energy < 500 then ctxt$ := "YELLOW";
	   if k3 > 0 then ctxt$ := "*RED*";
	end;

	if shldset > 0 then shldpc := shield * 100 / shldset;
	
  write "\t    ";;
  i := 1;
  while i < 9 do
  begin
     write i," ";;
     i := i + 1;	
  end;

  i := 0;
  a := 1;
  write "\n\n\t",a,"  ";;	
  while i < 100 do
  begin
     if sect[i] = -1 then
     begin
	i := i + 1;
	continue;
     end;
     ch := sect[i];
     if ch = 0 then ch := 46;
     #write ch%c," ";;
          if ch = '.' then begin write " . ";; end
     else if ch = '!' then begin write ">!<";; end
     else if ch = '*' then begin write " * ";; end
     else if ch = 'K' then begin write "+K+";; end
     else if ch = 'E' then begin write "<E>";; end
     else write "#",ch;;
     j := (i + 2) mod 10;
     if j = 0 then
     begin
	     if a = 1 then begin write "\tStardate\t",sdate / 10,".",sdate mod 10;; end
	else if a = 2 then begin write "\tCondition\t",ctxt$;; end
	else if a = 3 then begin write "\tQuadrant\t",x/10,",",x mod 10;; end
	else if a = 4 then begin write "\tSector\t\t",s1/10,",",s1 mod 10;; end
	else if a = 5 then begin write "\tPhoton Torp\t",torp;; end
	else if a = 6 then begin write "\tTotal Energy\t",energy + shield;; end
	else if a = 7 then begin write "\tShield Energy\t",shield," -",shldpc,"%";; end
	else if a = 8 then begin write "\tKlingons\t",k9;;
	end;
        a := a + 1;
        if a < 9 then write "\n\t",a,"  ";;	
     end;
     i := i + 1;
  end;
	  
	write "\n";
		
end;

procedure lrscan;
var i,j,x,y;

begin

   parameters x;
	
   write "\nLong Range Scan\n";

   x := x - 11;

   i := 0;
   j := 0;
   while i < 3 do
   begin
	while j < 3 do
	begin
		y := galaxy[x+j];
		galmap[x+j] := y;
		if y = -1 then begin write " ---\t";; end else write y,"\t";;
		j := j + 1;
	end;
	write "\n";
	j := 0;
	i := i + 1;
	x := x + 10;
   end;

end;

procedure getchr;

var ch;

begin
	ch := 0;
	while ch = 0 do
	begin
	  	ch := inkey;
		rnd := rnd + 1;		# Used to seed random number generator	
	end;
	result := ch;
end;

procedure navigate;

var course,warp,ecost,x1,y1,s2,
	 a,b;

begin

	write "Navigation\n";

	distance := 0;

	write "Course (1-9) ? ";;
	ch := getchr;
	write ch%c;
	course := ch - 48;

	write "Warp   (1-8) ? 0.";;
	ch := getchr;
	write ch%c;
	warp := ch - 48;

	write "Course ",course," warp factor ",warp;

	if warp < 1 or warp > 8 then
	begin
		write "Invalid warp speed setting";
		exit;
	end;

	ecost := warp * (2 * warp);

	write "Energy cost =",ecost;

	if ecost > energy then
	begin
		write "Insufficient energy for manoeuvre";
		exit;
	end;

	sdate := sdate - 1;

	course := course * 2;
	x := navdat[course];
	y := navdat[course+1];
	
	while warp > 0 do
	begin
		write "Nav Data is X=",x," Y=",y;

		y1 := s1/10;		#x1 & y1 equal to current Enterprise sector location
		x1 := s1 mod 10;

		x1 := x1 + x;		#Update current x,y position by direction one move
		y1 := y1 + y;

		write "New sect Y,X = ",y1,x1;

		s2 := y1*10 + x1;	#s2 new sector location index

		write "Checking sector location ",s2;
		a := sect[s2];
		write "sect[s2] =",a;
	
		     if a = '*' then begin write "Blocked by Star"; 			end
		else if a = 'K' then begin write "Blocked by Klingon"; 		end
		else if a = '!' then begin write "Blocked by Starbase"; 	end
		else if a = -1  then begin write "Blocked by Sector Edge"; end
		else begin
			write "Navigation good";
			distance := distance + 1;
		end;

		if a = 0 then
		begin
			sect[s2] := 'E';
			sect[s1] := 0;
			s1 := s2;
			energy := energy - ecost;
		end
		else begin
			write "Bad navigation";
			break;
		end;
		warp := warp - 1;
	end;

	if sect[s1-1] = '!' or sect[s1+1] = '!' then
	begin
		docked := true;
		write "Successfully docked with Starbase";
		energy  := emax;
		shield  := 0;
		shldset := 0;
		torp    := tmax;
	end else docked := false;

	call srscan passing q1;

end;

procedure warpdrive;

var course,warp,ecost,x1,y1,q2,
	 a,b;

begin

	write "Warp Drive\n";

	distance := 0;

	write "Course (1-9) ? ";;
	ch := getchr;
	write ch%c;
	course := ch - 48;

	write "Warp   (1-8) ? ";;
	ch := getchr;
	write ch%c;
	warp := ch - 48;

	write "Course ",course," warp factor ",warp;

	if warp < 1 or warp > 8 then
	begin
		write "Invalid warp speed setting";
		exit;
	end;

	a := warp + 10;

	ecost := a * (2 * a);

	write "Energy cost =",ecost;

	if ecost > energy then
	begin
		write "Insufficient energy for manoeuvre";
		exit;
	end;

	sdate := sdate - 1;

	course := course * 2;
	x := navdat[course];
	y := navdat[course+1];
	
	while warp > 0 do
	begin
		write "Nav Data is X=",x," Y=",y;

		y1 := q1/10;		#x1 & y1 equal to current Enterprise quadrant location
		x1 := q1 mod 10;

		x1 := x1 + x;		#Update current x,y position by direction one move
		y1 := y1 + y;

		write "New quadrant Y,X = ",y1,x1;

		q2 := y1*10 + x1;	#q2 new quadrant location index

		write "Checking sector location ",q2;
		a := galaxy[q2];
		write "galaxy[q2] =",a;
	
			if a = -1 then begin write "Blocked by Galaxy edge"; end
		else begin
			write "Navigation good";
			distance := distance + 1;
		end;

		if a != -1 then
		begin
			q1 := q2;
			energy := energy - ecost;
		end
		else begin
			write "Bad navigation";
			break;
		end;
		warp := warp - 1;
	end;

	if sect[s1-1] = '!' or sect[s1+1] = '!' then
	begin
		docked := true;
		write "Successfully docked with Starbase";
		energy  := emax;
		shield  := 0;
		shldset := 0;
		torp    := tmax;
	end else docked := false;

	call setupsector passing q1;
	call srscan passing q1;

end;

procedure deflectors;

var a,b;

begin

	write "Deflector Shield Control\n";

	write "Energy currently assigned to shields: ",shldset;
	write "New level to assign (0-300) ? ";;
	read	a;

	if a < 0 then a := 0;
	if a > defmax then a := defmax;

	shldset := a;

	if shldset > shield then
	begin
		a := shield - shldset;
		energy := energy + a;
		shield := shldset;
	end
	else shield := shldset;

	write "Deflector shields now at ",shield;

end;

procedure helpmsg;

var a,b;

begin

	write "Valid commands:\n";

	write " (N)avigate sector";
	write " (W)arp drive";
	write " (D)eflector shields";
	write " (L)ong range scan";
	write " (S)hort range scan";
	write " (M)ap of Galaxy";
	write " (P)hasors";
	write " (R)report damage";
	write " (Q)uit\n";

end;

procedure distance;

var a,b,i,j,
	 x1,y1,x2,y2,
	 r1,d;

begin

	parameters a,b;

	#write "Calculate distance between two sector locations";
	#write "Distance between ",a," and ",b;

	y1 := a /10;
	x1 := a mod 10;

	y2 := b /10;
	x2 := b mod 10;

	a := x1 - x2;
	b := y1 - y2;

	if neg a then a := -1 * a;
	if neg b then b := -1 * b;

	if a > b then b := a;

	result := b;

end;

procedure damagectrl;

var a,b,i,j,
    r1,d;

begin

	write "Damage Control";

	d := -1 * shield;
	shield := 0;

	r1 := (random / 9362);		# Number between 0 and 7

	damage[r1] := damage[r1] - d;
	write d," unit hit to ",system[r1]%s," now at ",damage[r1],"%";
	
end;

procedure klingons;

var a,b,i,j,
	 r1,d;

begin

	#write "Klingons Attack:\n"; 	write "There are ",k3," Klingons here!";

	i := 0;
	j := k3;
	while j != 0 do
	begin
	
		if klingon[i*3] = 0 then		# This Klingon destroyed already?
		begin
			i := i + 1;						# Yes? Then skip and loop again
			continue;
		end;
		
#		write "Klingon #",i," Location: ",klingon[i*3];
#		write "Klingon #",i," Energy  : ",klingon[i*3+1];
#		write "Klingon #",i," Shields : ",klingon[i*3+2];

		d := distance passing klingon[i*3], s1;

		#write "Distance between starships is ",d;

		r1 := (random / 655)/2;		# Approx 0-50 energy
		
		r1 := r1 - (d * 3);			# Subtract distance penalty from hit (3-24)

		if neg r1 then continue;	# If after distance adjustment hit is negative then just loop
		
		shield := shield - r1;
		if neg shield then call damagectrl 
			else write r1," unit hit from Klingon at location ",klingon[i*3];

		i := i + 1;			# Increment index to klingon array
		j := j - 1;			# Decrement count of klingon's processed

	end;
	
end;

procedure damagereport;

var a,b,i,j,
	 r1,d;

begin

	write "\nDamage Report\n";

	i := 0;
	while i < 8 do
	begin
		write system[i]%s,"\t at ",damage[i],"%";
		i := i + 1;
	end;
	write "\n";
	
end;

procedure phasors;

var loc,e,e1,i,j,
	 r1,d;

begin

	write "Phasers\n";
	
	write "Energy to fire ? ";;
	read	e;

	if e > energy then e := energy;			# Stupid becuase this would leave you dead in the void

	energy := energy - e;

	e := e / k3;		# Divide energy evenly between targets

	i := 0;
	j := k3;				# Number of Klingons in sector to target
	while j != 0 do
	begin

		write "Klingon #",i," Location: ",klingon[i*3];
		write "Klingon #",i," Energy  : ",klingon[i*3+1];
		write "Klingon #",i," Shields : ",klingon[i*3+2];
		
		if klingon[i*3] = 0 then		# This Klingon destroyed already?
		begin
			i := i + 1;						# Yes? Then skip and loop again
			continue;
		end;
		
		d := distance passing klingon[i*3], s1;

		write "Distance between starships is ",d;

		# What about Klingon shields?
		e1 := e - (d * 3);			# Subtract distance penalty from hit (3-24)

		if neg e1 then e1 := 0; 	# If after distance adjustment if hit is negative then hit is zero
		
		write e1," unit hit on Klingon at ",klingon[i*3];

		klingon[i*3+2] := klingon[i*3+2] - e1;
		if neg klingon[i*3+2] then
			begin
				loc := klingon[i*3];
				write "Klingon at ",loc," destroyed!";
				k3 := k3 - 1;						# Reduce Klingon number in sector by one
				k9 := k9 - 1;						# Reduce Klingon number in galaxy by one
				galaxy[q1] := galaxy[q1] - 1;	# Adjust galaxy record for this quadrant
				galmap[q1] := galaxy[q1];		# Update the players galaxy map with this quadrant's current details
				sect[loc] := 0;					# Clear destroyed Klingon from sector map
			end;

		write "Klingon #",i," Location: ",klingon[i*3];
		write "Klingon #",i," Energy  : ",klingon[i*3+1];
		write "Klingon #",i," Shields : ",klingon[i*3+2];

		i := i + 1;			# Increment index to klingon array
		j := j - 1;			# Decrement count of klingon's processed

	end;

end;

procedure repairs;

var i,j,a;

begin

	write "Underway Repairs";

	i := 0;
	while i < 8 do
	begin
		if damage[i] < 100 then
		begin
			damage[i] := damage[i] + 10;						# Restore system health by 10%
			if damage[i] > 100 then damage[i] := 100;		# System health maximum 100%
			write "Damage control reports:";
			write system[i]%s," has been restored to ",damage[i],"% health";
			exit;
		end;
		i := i + 1;
	end;

end;

begin

  write "PISC pl/0+ Super Star Trek Program\n";

  randomize := 1246;

	sdate := startdate;

	energy	:= emax;		# Maximum energy
	shield	:= 0;			# Shield energy at zero
	shldset	:= 0;			# Shield set point
	torp  	:= tmax;		# Maximum Photon Torpedoes

	system[sys_life] 		:= "Life Support"@;
	system[sys_warp] 		:= "Warp Engines"@;
	system[sys_shield] 	:= "Shield Control"@;
	system[sys_srs] 		:= "S.Range Sensors"@;
	system[sys_lrs] 		:= "L.Range Sensors"@;
	system[sys_phaser]	:= "Phaser Control"@;
	system[sys_photon] 	:= "Photon Tubes"@;
	system[sys_damage] 	:= "Damage Control"@;

	i := 0;
	while i < 8 do
	begin
		damage[i] := 100;		# All systems set to 100% health at start
		i := i + 1;
	end;

	docked := false;

	#navdir := "0-1-101101-1-0-1";
	navdir := "00-10111-00010--0-1-";

	i := 0;
	while i < 20 do
	begin
		if navdir{i} = '0' then begin write "X= 0"; x :=  0; end;
		if navdir{i} = '-' then begin write "X=-1"; x := -1; end;
		if navdir{i} = '1' then begin write "X= 1"; x :=  1; end;

		if navdir{i+1} = '0' then begin write "Y= 0"; y :=  0; end;
		if navdir{i+1} = '-' then begin write "Y=-1"; y := -1; end;
		if navdir{i+1} = '1' then begin write "Y= 1"; y :=  1; end;
		
		navdat[i]   := x;
		navdat[i+1] := y;

		write "Nav Data ",i, " = ",navdat[i];
		write "Nav Data ",i+1, " = ",navdat[i+1];

		i := i + 2;
	
	end;

	i := 0;
	while i < 8 do
	begin
		write "Direction ",i," is X=",navdat[i*2]," Y=",navdat[i*2+1];
		i := i + 1;
	end;

  call bigbang;	
  #call galaxymap;

  q1 := 23;

  call sitrep;
  call setupsector passing q1;

	#call lrscan passing q1;
	call srscan passing q1;

	#call dump passing galmap@; call dump passing galaxy@;

	forever := true;

	while forever = true do
	begin

		write "Enter command: ";;
		ch := getchr;
		write ch%c;
		if ch > 'Z' then ch := ch - 32;

			if ch = 'N' then call navigate
		else if ch = 'W' then call warpdrive
		else if ch = 'D' then call deflectors
		else if ch = 'L' then call lrscan passing q1
		else if ch = 'S' then begin
			call srscan passing q1;
			continue;
		end
		else if ch = 'M' then call galaxymap
		else if ch = 'P' then call phasors
		else if ch = 'R' then call damagereport
		else if ch = 'Z' then call dump passing galmap@
		else if ch = 'Q' then exit
		else begin
			call helpmsg;
			continue;
		end;
	
		if shield > 0 then energy := energy - 10;		# Energy cost of holding deflector shields up per turn

		call klingons;

		if shldset > shield and energy > 500 then
		begin
			a := shldset - shield;
			if a > damage[sys_shield] / 2 then a := damage[sys_shield] / 2;
			energy := energy - a;
			shield := shield + a;
			write "Deflector shield recharges ",a," units.";
		end;

		if k3 = 0 then call repairs;		# Not under Klingon attack so make some running repairs

	end;

end .