Oakland CPM Archive

home *** CD-ROM | disk | FTP | other *** search

/ Oakland CPM Archive / oakcpm.iso / cpmug / cpmug080.ark / TRADE.STB < prev next >

Wrap

Text File | 1984-04-29 | 18.3 KB | 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