ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/SIMTEL/CPMUG/CPMUG080.ARK/TRADE.STB

Text File | 1984-04-29 | 19KB | 464 lines

   10   Rem Star Traders
   20   Rem For Cromemco Structured Basic
   30   Rem Version 06/23/81
   35   Imode : I=1.23 : If I=1.23 Then Run
   40   Integer No'players,Player,Move,I,J,K,L,M,Bad,A(4)
   44   Integer Loser,Survivor,X,Y,Legal'x(6),Legal'y(6)
   45   Integer Map(10,13),Company'branches(6),Shares(5,4)
   50   Long Net'worth(6),Cash(6),Share'price(6),Rand
   60   Dim Companies$(5*18),Company$(18),Players$(5*10),L$(8),M$(12)
   61   Dim Player$(10)
   65   Randomize
   70   Gosub Title
   90   Gosub Initialize'galaxy
  100   Gosub Setup'players
  110     Repeat
  115       For Player=1 To No'players
  120       Gosub Print'map
  130       Gosub Select'legal'moves
  140       Gosub Print'moves
  150       Gosub Enter'move
  170       Gosub Check'move
  190       Gosub Dividends
  191       Gosub Buy'stock
  195       Move=Move+1
  196       Next Player
  200     Until Move>=48
  210   Gosub Calculate'winner
  220   End
  222 *Title
  223   Call .Screen'erase
  224   @"              **********   Star Traders   **********" : @ : @ : @
  226   Return
  230 *Initialize'galaxy
  235   Local I,J
  240     For I=1 To 5
  250     Read Companies$((I-1)*18,I*18-1)
  260     Next I
  270   Data"Altair Starways","Betelgeuse, Ltd.","Capella Freight co."
  280   Data"Denebola Shippers","Eridani Expediters"
  310   Mat Shares=0 : Mat Company'branches=0 : Mat Share'price=0
  315   Mat Net'worth=0 : Mat Map=1 : Mat Cash=6000
  320   L$=".+*ABCDE"
  330   M$=" ABCDEFGHIJKL"
  335   Move=0
  400     For I=1 To 9
  410       For J=1 To 12
  420       Rand=10*Rnd(0)+1
  440       If Int(Rand)=10 Then Map(I,J)=3
  450       Next J
  460     Next I
  465   Return
  470 *Setup'players
  480   @
  485     Repeat
  490     Input"How many players (1-4)? ",Command$
  493     If Command$="" Then Command$="0"
  494     No'players=Val(Command$)
  495     Until No'players>0 And No'players<5
  500   @ : @
  501     Repeat
  510     Input"Does any player need instructions (Y/N)? ",Command$
  515     Call .Capitalize (Command$)
  519     Until Command$(0,0)="Y" Or Command$(0,0)="N"
  520   If Command$(0,0)="Y" Then Gosub Instructions
  530   Call .Screen'erase
  540     For I=1 To No'players
  545     @
  546       Repeat
  550       @"Player",I,
  560       Input"What is your name? ",Player$
  561       Until Player$<>""
  562     Players$((I-1)*10,I*10-1)=Player$
  570     Next I
  590   Player=Int(No'players*Rnd(0)+1)
  600   @ : @ Players$((Player-1)*10,Player*10-1);" is the first player to move."
  610   @ : Gosub Press'return
  630   Return
  660 *Select'legal'moves
  665   Local I,J,Bad,Rand
  670     For I=1 To 5
  675       Repeat
  676       Bad=0
  680       Legal'x(I)=Int(9*Rnd(0)+1)
  690       Legal'y(I)=Int(12*Rnd(0)+1)
  695       If Map(Legal'x(I),Legal'y(I))>1 Then Bad=1
  700         For J=I-1 To 0 Step-1
  710         If Legal'x(I)=Legal'x(J) And Legal'y(I)=Legal'y(J) Then Bad=1
  720         Next J
  738       J=0
  740         Repeat
  750         J=J+1
  760         Until J>5 Or Company'branches(J)=0
  761       Call .Surrounding'squares (Legal'x(I),Legal'y(I))
  765       If J>5 Then  Do
  770         If(A(1)<4) And(A(2)<4) And(A(3)<4) And(A(4)<4) Then  Do
  850           If(A(1)=2 Or A(1)=3) And A(2)<4 And A(3)<4 And A(4)<4 Then Bad=1
  860           If(A(2)=2 Or A(2)=3) And A(1)<4 And A(3)<4 And A(4)<4 Then Bad=1
  870           If(A(3)=2 Or A(3)=3) And A(1)<4 And A(2)<4 And A(4)<4 Then Bad=1
  880           If(A(4)=2 Or A(4)=3) And A(1)<4 And A(2)<4 And A(3)<4 Then Bad=1
  883           Enddo
  884         Enddo
  885       Until Bad=0
  930     Next I
  940   Return
  960 *Print'moves
  965   Local I
  966   Call .Erase'bottom (16)
  970   @ Players$((Player-1)*10,Player*10-1);" here are your legal moves for this turn:" : @
  990     For I=1 To 5
 1000     @ Legal'x(I);M$(Legal'y(I),Legal'y(I));" ";
 1010     Next I
 1020   @ : @
 1025   Return
 1026 *Enter'move
 1027     Repeat
 1028     Call .Erase'bottom (20)
 1029     Bad=1
 1030     Input"What is your move? ",Command$
 1035     Call .Capitalize (Command$)
 1040     If Command$(0,0)="M" Then Gosub Print'map : Gosub Print'moves
 1050     If Command$(0,0)="S" Then Gosub Display'holdings : Gosub Print'moves
 1060     If Command$(0,1)="HE" Then Gosub Instructions : Gosub Print'map : Gosub Print'moves
 1120     X=Val(Command$(0,0))
 1130     Y=Asc(Command$(1,1))-64
 1140       For I=1 To 5
 1150       If X=Legal'x(I) And Y=Legal'y(I) Then Bad=0
 1160       Next I
 1170     Until Bad=0
 1185   Return
 1190 *Check'move
 1200   Call .Surrounding'squares (X,Y)
 1230   If A(1)<=1 And A(2)<=1 And A(3)<=1 And A(4)<=1 Then Map(X,Y)=2 : Return
 1260   If A(1)>3 And A(2)>3 And A(2)<>A(1) Then Call .Merger (A(1),A(2)) : Return
 1270   If A(1)>3 And A(3)>3 And A(3)<>A(1) Then Call .Merger (A(1),A(3)) : Return
 1280   If A(1)>3 And A(4)>3 And A(4)<>A(1) Then Call .Merger (A(1),A(4)) : Return
 1290   If A(2)>3 And A(3)>3 And A(3)<>A(2) Then Call .Merger (A(2),A(3)) : Return
 1300   If A(2)>3 And A(4)>3 And A(4)<>A(2) Then Call .Merger (A(2),A(4)) : Return
 1310   If A(3)>3 And A(4)>3 And A(4)<>A(3) Then Call .Merger (A(3),A(4)) : Return
 1320   If A(1)<4 And A(2)<4 And A(3)<4 And A(4)<4 Then  Do
 1321     Gosub New'company
 1322     Else
 1323     Gosub Old'company
 1324     Enddo
 1325   Return
 1330 *Old'company
 1340   Local I,J
 1350     For J=1 To 4
 1360     If A(J)>3 Then I=A(J)-3
 1370     Next J
 1380   Company'branches(I)=Company'branches(I)+1
 1390   Share'price(I)=Share'price(I)+100
 1400   Map(X,Y)=I+3
 1405   Call .Change'price (I)
 1410   Return
 1415 *New'company
 1416   Local I
 1420     Repeat
 1425     I=I+1
 1430     Until I>5 Or Company'branches(I)=0
 1435   If I>5 Then  Do
 1450     If Map(X,Y)<3 Then Map(X,Y)=2
 1460     Else
 1470     Call .Screen'erase
 1480     Gosub Special'announcement
 1490     @"A new shipping company has been formed !"
 1500     @"It's name is ";Companies$((I-1)*18,(I*18)-1)
 1510     Shares(I,Player)=Shares(I,Player)+5
 1520     Company'branches(I)=1
 1525     Map(X,Y)=I+3
 1530     @ : @ : @ : @
 1532     Call .Change'price (I)
 1533     Enddo
 1534   Return
 1535 Procedure .Change'price (I)
 1540   Local J
 1550     For J=1 To 4
 1560     If A(J)=3 Then Share'price(I)=Share'price(I)+500
 1570     Next J
 1590     For J=1 To 4
 1600     If A(J)=2 Then  Do
 1610       Share'price(I)=Share'price(I)+100
 1620       Company'branches(I)=Company'branches(I)+1
 1630       If J=1 Then Map(X-1,Y)=I+3
 1631       If J=2 Then Map(X+1,Y)=I+3
 1632       If J=3 Then Map(X,Y-1)=I+3
 1633       If J=4 Then Map(X,Y+1)=I+3
 1640       Enddo
 1650     Next J
 1655   If Share'price(I)>3000 Then Call .Stock'split (I)
 1774   Endproc
 1775 *Dividends
 1776   Local I,J
 1780     For I=1 To 5
 1790     Cash(Player)=Cash(Player)+Int(0.05*Shares(I,Player)*Share'price(I))
 1800     Next I
 1801   Return
 1802 *Buy'stock
 1810     For I=1 To 5
 1815       Repeat
 1816       Bad=0
 1820       If Company'branches(I)>0 And Cash(Player)>200 Then  Do
 1825         Call .Erase'bottom (16)
 1830         @ : @"Your current cash= $";Cash(Player);"."
 1850         @"You now own shares ";Shares(I,Player);" of ";Companies$((I-1)*18,I*18-1)
 1860         @"Buy how many shares at $";Share'price(I);" per share? ";
 1870         Input"",Command$
 1880         If Command$(0,0)="M" Then Gosub Print'map : Bad=1
 1920         If Command$(0,0)="S" Then Gosub Display'holdings : Bad=1
 1940         If Command$(0,1)="HE" Then Gosub Instructions : Gosub Print'map : Bad=1
 1950         If Command$="" Then Command$="0"
 1960         J=Val(Command$(0))
 1980         If(J*Share'price(I)<=Cash(Player)) And J>0 Then  Do
 2020           Shares(I,Player)=Shares(I,Player)+J
 2030           Cash(Player)=Cash(Player)-(J*Share'price(I))
 2034           Else
 2035           If J>0 Then @"You don't have that much money!" : Gosub Press'return : Bad=1
 2036           Enddo
 2037         Enddo
 2038       Until Bad=0
 2040     Next I
 2050   Return
 2051 Procedure .Surrounding'squares (I,J)
 2052   A(1)=Map(I-1,J)
 2053   A(2)=Map(I+1,J)
 2054   A(3)=Map(I,J-1)
 2055   A(4)=Map(I,J+1)
 2056   Endproc
 2060 *Print'map : Call .Screen'erase
 2065   @"Move: ";Move
 2070   @ Tab(22);"Map of the Galaxy"
 2080   @ Tab(21);"*******************" : @
 2090   @ Tab(11);" A  B  C  D  E  F  G  H  I  J  K  L"
 2095   Local I,J,K
 2100     For I=1 To 9
 2110     @"         ";I;" ";
 2120       For J=1 To 12
 2130       @" ";
 2140       K=Map(I,J)
 2150       If K=0 Then K=K+1
 2160       @ L$(K-1,K-1);" ";
 2170       Next J
 2180     @
 2190     Next I
 2195   @ : @
 2200   Return
 2210 Procedure .Merger (L,M)
 2215   Local I,J,K
 2216   L=L-3 : M=M-3
 2220   If Company'branches(L)>=Company'branches(M) Then Survivor=L : Loser=M
 2230   If Company'branches(M)>Company'branches(L) Then Loser=L : Survivor=M
 2500   Call .Screen'erase
 2510   Gosub Special'announcement
 2520   @ Companies$((Loser-1)*18,Loser*18-1);" has just been merged into ";
 2530   @ Companies$((Survivor-1)*18,Survivor*18-1);"!"
 2540   @"Please note the following transactions."
 2550   @
 2560   @ Tab(3);"Old stock = ";Companies$((Loser-1)*18,Loser*18-1);
 2570   @"      New stock = ";Companies$((Survivor-1)*18,Survivor*18-1)
 2580   @
 2590   @"Player";Tab(10);"Old stock";Tab(22);"New stock";
 2600   @ Tab(34);"Total Holdings";Tab(53);"Bonus Paid"
 2610     For I=1 To No'players
 2615     Player$=Players$((I-1)*10,I*10-1)
 2630     @ Player$;Tab(10);Shares(Loser,I);Tab(22);Int((0.5*Shares(Loser,I))+0.5);
 2640     @ Tab(34);Shares(Survivor,I)+Int((0.5*Shares(Loser,I))+0.5);
 2650     K=0
 2660       For J=1 To No'players
 2670       K=K+Shares(Loser,J)
 2680       Next J
 2690     @ Tab(53);" $";Int(10*((Shares(Loser,I)/K)*Share'price(Loser)))
 2700     Next I
 2710     For I=1 To No'players
 2720     Shares(Survivor,I)=Shares(Survivor,I)+Int((0.5*Shares(Loser,I))+0.5)
 2730     Cash(I)=Cash(I)+Int(10*((Shares(Loser,I)/K)*Share'price(Loser)))
 2740     Next I
 2750     For I=1 To 9
 2760       For J=1 To 12
 2770       If Map(I,J)=Loser+3 Then Map(I,J)=Survivor+3
 2780       Next J
 2790     Next I
 2880   Company'branches(Survivor)=Company'branches(Survivor)+Company'branches(Loser)
 2890   Share'price(Survivor)=Share'price(Survivor)+Share'price(Loser)
 2900   If Share'price(Survivor)>=3000 Then Call .Stock'split (Survivor)
 2950   Share'price(Loser)=100
 2960   Company'branches(Loser)=0
 2970     For I=1 To No'players
 2980     Shares(Loser,I)=0
 2990     Next I
 3000   @ : @
 3010   Map(X,Y)=Survivor+3
 3020   Endproc
 3030 Procedure .Stock'split (L)
 3034   Local I
 3035   Call .Erase'bottom (16)
 3036   Gosub Special'announcement
 3040   @"The stock of ";Companies$((L-1)*18,L*18-1);
 3050   @" has split 2 for 1!"
 3060   Share'price(L)=Int(Share'price(L)/2)
 3070   @ : @
 3080     For I=1 To No'players
 3090     Shares(L,I)=2*Shares(L,I)
 3100     Next I
 3105   Gosub Press'return
 3110   Endproc
 3120 *Display'holdings : Call .Screen'erase
 3125   Local I
 3130   @
 3140   @"Stock";Tab(30);"Price Per Share";
 3150   @ Tab(50);"Your Holdings"
 3160     For I=1 To 5
 3180     Company$=Companies$((I-1)*18,I*18-1)
 3190     @ Company$;Tab(36);Share'price(I);Tab(55);Shares(I,Player)
 3200     Next I
 3210   Return
 3215 *Special'announcement
 3220   @ Chr$(7)
 3230   @ Tab(22);"Special Announcement !!!" : @ : @
 3250   Return
 3255 *Press'return
 3260   Input"Press RETURN to go on. ",Command$
 3270   Return
 3280 *Instructions
 3290   Call .Screen'erase
 3300   @"   Star lanes is a game of interstellar trading."
 3310   @"The object of the game is to amass the greatest amount"
 3320   @"of money.  This is accomplished by establishing vast,"
 3330   @"interstellar shipping lanes, and purchasing stock in"
 3340   @"the companies that control those trade routes.  During"
 3350   @"the course of the game, stock appreciates in value as"
 3360   @"the shipping companies become larger.  Also, smaller"
 3370   @"companies can be merged into larger ones, and stock"
 3380   @"in the smaller firm is converted into stock in the"
 3390   @"larger one as described below." : @
 3400   @"Each turn, the computer will present the player with"
 3410   @"five prospective spaces to occupy on a 9x12 matrix"
 3420   @"(rows 1-9, columns A-L).  The player, after examining"
 3430   @"the map of the galaxy to decide which space he wishes"
 3440   @"to occupy, responds with the row and column of that"
 3450   @"space, i.e., 7E, 8A, etc.  There are four possible"
 3460   @"moves a player can make." : @ : @
 3470   @
 3510   Gosub Press'return
 3530   Call .Screen'erase
 3540   @"   1. He can establish an unattached outpost- if he"
 3550   @"selects a space that is not adjacent to a star, another"
 3560   @"unattached outpost, or an existing shipping lane, this"
 3570   @"space will be designated with a '+'.  He will then proceed"
 3580   @"with stock transactions, as listed below." : @
 3590   @"   2. He can add to an existing lane- if he selects a"
 3600   @"space that is adjacent to one - and only one existing"
 3610   @"shipping lane, the space he selects will be added to"
 3620   @"that shipping lane and will be designated with the first"
 3630   @"letter of the company that owns that lane.  If there are"
 3640   @"any stars or unattached outposts also adjacent to the"
 3650   @"selected space, they, too, will be incorporated into the"
 3660   @"existing lane.  Each new square adjacent to a star adds"
 3670   @"$500 per share, and each new outpost adds $100 per share"
 3680   @"to the market value of the stock of that company."
 3690   @ : @
 3700   Gosub Press'return
 3710   Call .Screen'erase
 3720   @"   3. He may establish a new shipping lane- if there"
 3730   @"are five or less existing shipping lanes established,"
 3740   @"the player may, given the proper space to play, establish"
 3750   @"a new shipping lane.  He may do this by occupying a space"
 3760   @"adjacent to a star or another unattached outpost, but"
 3770   @"not adjacent to an existing shipping lane.  If he"
 3780   @"establishes a new shipping lane, he is automatically"
 3790   @"issued 5 shares in the new company as a reward.  He"
 3800   @"may then proceed to buy stock in any active company,"
 3810   @"including the one just formed, as described below."
 3820   @"the market value of the new stock is established by"
 3830   @"the number of stars and occupied spaces as described"
 3840   @"in #2 above."
 3850   @ : @
 3860   Gosub Press'return
 3870   Call .Screen'erase
 3880   @"   4.  He may merge two existing companies- if a player"
 3890   @"selects a space adjacent to two existing shipping"
 3900   @"lanes, a merger occurs.  The larger company takes over the"
 3910   @"smaller company - (if both companies are the same size"
 3920   @"prior to the merger, then the survivor is determined by"
 3930   @"alphabetical order of the two company names - the earlier"
 3940   @"survives).  The stock of the surviving company is"
 3950   @"increased in value according to the number of spaces"
 3960   @"and stars added to its lane.  Each player's stock in"
 3970   @"the defunct company is exchanged for shares in the"
 3980   @"survivor on a ratio of 2 for 1.  Also, each player"
 3990   @"is paid a cash bonus proportional to the percentage"
 4000   @"of outstanding stock he held in the defunct company."
 4010   @"Note: After a company becomes defunct through the"
 4020   @"merger process, it can reappear elsewhere on the"
 4030   @"board when, and if, a new company is established."
 4040   @ : @
 4050   Gosub Press'return
 4060   Call .Screen'erase
 4070   @"   Next the computer adds stock dividends to the player's"
 4080   @"cash on hand (5% of the market value of the stock in his"
 4090   @"possession), and offers him the opportunity to purchase"
 4100   @"stock in any of the active companies on the board."
 4110   @"Stock may not be sold, but the market value of each"
 4120   @"player's stock is taken into account at the end of the"
 4130   @"game to determine the winner. if the market value of a given"
 4140   @"stock exceeds $3000 at any time during the game, that"
 4150   @"stock splits 2 for 1.  The price is cut in half, and"
 4160   @"the number of shares owned by each player is doubled."
 4170   @
 4180   @"Note:  The player may look at his portfolio at any time"
 4190   @"during the course of his turn by responding with 'S'tock"
 4200   @"to an input statement.  Likewise, he can review the map"
 4210   @"of the galaxy by typing 'M'ap to an input statement."
 4220   @ : @
 4230   Gosub Press'return
 4240   Call .Screen'erase
 4250   @ : @ : @ : @ : @ : @ : @ : @
 4260   @ Tab(16);"** Game ends after 48 moves **"
 4270   @ : @ : @ : @
 4280   @"Player with the greatest net worth at that point is the winner."
 4290   @ : @
 4300   Gosub Press'return
 4310   Return
 4315 *Calculate'winner
 4316   Local I,J
 4320   Call .Screen'erase
 4330   Gosub Special'announcement
 4360   @ Tab(10)," The game is over - here are the final standings"
 4370   @ : @ : @ : @
 4380   @ Chr$(7)
 4390   @"Player";Tab(10);"Cash Value of Stock";Tab(33);"Cash on Hand";
 4400   @ Tab(50);"Net Worth"
 4410   @
 4420     For I=1 To No'players
 4430       For J=1 To 5
 4440       Net'worth(I)=Net'worth(I)+(Share'price(J)*Shares(J,I))
 4450       Next J
 4460     Next I
 4470     For I=1 To No'players
 4480     Player$=Players$((I-1)*10,I*10-1)
 4490     @ Player$;Tab(10);"$";Net'worth(I);Tab(33);"$";Cash(I);
 4500     @ Tab(50);"$";Net'worth(I)+Cash(I)
 4510     Next I
 4520   @ : @ : @ : @
 4530   Return
 9000 Procedure .Capitalize (Command$)
 9010   Local I
 9020     For I=0 To Len(Command$)-1
 9030     If Command$(I,I)>="a" And Command$(I,I)<="z" Then  Do
 9040       Command$(I,I)=Chr$(Asc(Command$(I,I))-32)
 9050       Enddo
 9060     Next I
 9070   Endproc
10000 Procedure .Screen'erase
10010   Out 1,126 : Out 1,28
10020   Endproc
10030 Procedure .Cursor'address (X,Y)
10040   Out 1,126 : Out 1,17 : Out 1,X : Out 1,Y
10050   Endproc
10060 Procedure .Erase'bottom (Y)
10070   Call .Cursor'address (0,Y)
10080   Out 1,126 : Out 1,24
10090   Endproc