'program teabag.tea
'Written in Teapro which uses the OpenTea technology
'TADDRESS.TEA
'People need computer software that actually works.
vari dg_pass1, dg_pass2, dg_pass3, dg_pass4
vari sg_pass1, sg_pass2, sg_pass3, sg_pass4
vari sg_addressexp, sg_addressran
vari dg_begrec, dg_endrec
vari dg_changes
vari dg_textbyte
vari sg_10, sg_13, sg_32
'teacard
vari dg_cmarbles, dg_pmarbles, dg_craise, dg_praise, dg_pot
vari dg_hand, dg_round, dg_continue, dg_playing, dg_bet
vari dg_cvalue, dg_pvalue, dg_tvalue
'TeaProperty, begun 02-JAN-1999
vari dg_ploc, dg_cloc, dg_pmoney, dg_cmoney, sg_change
vari dg_dice1, dg_dice2, sg_dice
vari dg_bankct, dg_auto, sg_card, sg_community
vari dg_coutofjailfree, dg_poutofjailfree
'TEA_OVER, program begun on 07-JAN-1999
vari sg_board1, sg_board2, sg_board3
vari dg_existingmovec, dg_existingmovep
vari dg_ccount, dg_pcount
'TeaPair, program begun on 02-SEP-1999
vari sg_pairings, dg_players, dg_pairingsshow, sg_round
vari dg_bad1, dg_bad2
sub_main
endp
subr sub_main
'updated 2008/02/26, 2006/03/03, 2002/11/10
vari d_any, s_any, d_dot, s_dot
vari s_pick, d_pick, d_loop
d_loop = 1
dwhi d_loop = 1
$ch$ s_any, "-", 70
$out s_any
$out "Program: teabag.tea, build 22, 2009/10/25"
$out "Copyright (c) 1998-2008 D La Pierre Ballard"
$out "Written in Teapro which uses the OpenTea technology"
$out "Copyright (c) 1997-2008 D La Pierre Ballard"
$out "People need computer software that actually works."
$out s_any
sub_speedquick
$out "1. Addresses"
$out "2. TeaCard"
$out "3. TeaProperty"
$out "4. Tea_over"
$out "5. Hands"
$out "6. Pairing for rounds of a tournament"
$out "7. JumpOver"
$out "8. Roulette"
$out "98. prime speed test " + dg_pass1
$inp s_pick, "choose one, * to end"
$ift s_pick = "*": dinc d_loop
$isd d_any, s_pick
d_pick = 0
dift d_any = 1: $tod d_pick, s_pick
dift d_pick = 1: sub_address
dift d_pick = 2: sub_teacard
dift d_pick = 3: sub_TeaProperty
dift d_pick = 4: sub_tea_over_prog
dift d_pick = 5: sub_hands_main
dift d_pick = 6: sub_pairing_rounds
dift d_pick = 7: sub_jumpover_main
dift d_pick = 8: sub_roulette
dift d_pick = 98: sub_prime_speed_test
endw
ends sub_main
subr sub_roulette
'updated 2002/12/20
vari d_any, s_any, d_dot, s_dot, s_out
vari d_loop, d_good, d_ball, d_result, s_color
vari d_putroubles, d_putpick, d_totroubles, d_winroubles
vari d_fixcount, d_fixpick
vari s_part1, s_part2, d_show
vari s_dashes, s_input
$ch$ s_dashes, "-", 70
d_winroubles = 0
d_totroubles = 1000
$inp s_any, "1=show ball"
d_show = 2
$ift s_any = "1": d_show = 1
d_fixpick = 0
d_fixcount = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
$out s_dashes
$out "you have won=" + d_winroubles
$out "your gold roubles=" + d_totroubles
$out "choose on a number 1 to 36"
$out "choose r=red or b=black"
$out "100,28 means put 100 roubles on 28"
$out "50,r means 50 roubles on red"
$out s_dashes
$inp s_input, "* to end"
$ift s_input = "*"
dinc d_loop
dinc d_good
endi
dift d_good = 1
$cup s_input, s_input
$par s_part1, s_input, ",", 1
$par s_part2, s_input, ",", 2
$trb s_part1, s_part1
$trb s_part2, s_part2
$isd d_any, s_part1
dift d_any <> 1: dinc d_good
endi
dift d_good = 1
$tod d_putroubles, s_part1
dift d_putroubles < 1: dinc d_good
dift d_putroubles > d_totroubles: dinc d_good
endi
dift d_good = 1
$isd d_any, s_part2
dift d_any = 1
$tod d_putpick, s_part2
dift d_putpick < 1: dinc d_good
dift d_putpick > 36: dinc d_good
else
$cut s_part2, s_part2, 1, 1
$ift s_part2 = "R"
d_putpick = 50
s_part2 = "Red"
endi
$ift s_part2 = "B"
d_putpick = 50
s_part2 = "Black"
endi
dift d_putpick < 40: dinc d_good
endi
endi
dift d_good = 1
d_totroubles = d_totroubles - d_putroubles
d_winroubles = 0
d_dot = 1
dran d_result
d_result = d_result * 36 \ 1
dift d_result < 0: dinc d_dot
dift d_result > 36: dinc d_dot
dift d_dot <> 1
$out "d_result=" + d_result
d_result = 36
endi
endi
dift d_good = 1
dift d_putpick < 37
'fix so if d_putpick is the same 3 times it will come up
dift d_fixpick = d_putpick
dinc d_fixcount
dift d_fixcount = 3
d_result = d_putpick
d_fixpick = 99
endi
else
d_fixpick = d_putpick
d_fixcount = 1
endi
endi
endi
dift d_good = 1
dift d_show = 1
'roll the ball
dran d_ball
d_ball = d_ball * 36 \ 1
dift d_ball = d_result
dinc d_ball
dift d_ball > 36: d_ball = 0
endi
dwhi d_ball <> d_result
s_color = "Black"
d_any = d_ball % 2
dift d_any = 1: s_color = "Red"
$out "Ball=" + d_ball + " " + s_color
dinc d_ball
dift d_ball > 36: d_ball = 0
dpow d_dot, 10, 4
d_any = 0
dwhi d_any < d_dot
dinc d_any
endw
endw
else
d_ball = d_result
endi
s_color = "Black"
d_any = d_ball % 2
dift d_any = 1: s_color = "Red"
dift d_ball = 0: s_color = "0"
$out "Ball=" + d_ball + " " + s_color + " stopped"
dift d_putpick > 36
$ift s_color = s_part2
d_winroubles = d_putroubles * 2
d_totroubles = d_totroubles + d_winroubles
endi
else
dift d_putpick = d_result
d_winroubles = d_putroubles * 36
d_totroubles = d_totroubles + d_winroubles
endi
endi
endi
dift d_totroubles = 0
dinc d_loop
$inp s_any, "You are out of gold roubles."
endi
endw
ends sub_roulette
subr sub_jumpover_main
'updated 2002/05/20
vari d_any, s_any, d_dot, s_dot, s_out
vari s_board0, d_ply, d_totalct, d_winct
sub_jumpover_initialize
s_board0 = sg_pass1
sg_pass1 = s_board0
sub_jumpover_board
d_ply = 0
d_totalct = 0
d_winct = 0
sg_pass1 = s_board0
dg_pass1 = d_ply
dg_pass2 = d_totalct
dg_pass3 = d_winct
sub_jumpover_move
d_totalct = dg_pass2
d_winct = dg_pass3
s_out = "totalct=" + d_totalct + ", winct=" + d_winct
$out s_out
$inp s_any, "done"
ends sub_jumpover_main
subr sub_jumpover_initialize
'updated 2002/05/20
vari d_any, s_any, d_dot, s_dot
vari s_board0, s_where
$ch$ s_any, " ", 110
s_board0 = s_any
$app s_board0, " - "
$app s_board0, " P P "
$app s_board0, " P P P "
$app s_board0, " P P P P "
$app s_board0, "P P P P P "
$app s_board0, s_any
s_where = ""
$app s_where, " 15 "
$app s_where, " 24 26 "
$app s_where, " 33 35 37 "
$app s_where, " 42 44 46 48 "
$app s_where, "51 53 55 57 59"
'15 to 24 = 9
'15 to 26 = 11
'33 to 35 = 2
dtoi 1, 9
dtoi 2, 11
dtoi 3, 2
dtoi 4, -9
dtoi 5, -11
dtoi 6, -2
dtoi 101, 115
dtoi 102, 124
dtoi 103, 126
dtoi 104, 133
dtoi 105, 135
dtoi 106, 137
dtoi 107, 142
dtoi 108, 144
dtoi 109, 146
dtoi 110, 148
dtoi 111, 151
dtoi 112, 153
dtoi 113, 155
dtoi 114, 157
dtoi 115, 159
sg_pass1 = s_board0
ends sub_jumpover_initialize
subr sub_jumpover_move
'updated 2002/05/20
vari d_any, s_any, d_dot, s_dot, s_out
vari s_board1, s_board2, d_ply1, d_ply2
vari d_xmovefrom, d_movefrom, d_moveto
vari d_xdelta, d_delta, d_moveover
vari s_solution1, s_solution2
vari d_totalct, d_ynmove, d_winct, d_ynwin
s_board1 = sg_pass1
s_solution1 = sg_pass2
d_ply1 = dg_pass1
d_ply2 = d_ply1 + 1
d_totalct = dg_pass2
d_winct = dg_pass3
d_ynmove = 2
d_xmovefrom = 101
dwhi d_xmovefrom <= 115
itod d_movefrom, d_xmovefrom
$cut s_any, s_board1, d_movefrom, 1
$ift s_any = "P"
d_xdelta = 1
dwhi d_xdelta <= 6
itod d_delta, d_xdelta
d_moveover = d_movefrom + d_delta
$cut s_any, s_board1, d_moveover, 1
$ift s_any = "P"
d_moveto = d_moveover + d_delta
$cut s_any, s_board1, d_moveto, 1
$ift s_any = "-"
'we have a move
d_ynmove = 1
s_board2 = s_board1
$rep s_board2, d_movefrom, "-"
$rep s_board2, d_moveover, "-"
$rep s_board2, d_moveto, "P"
's_out = "from=" + d_movefrom
'$app s_out, ", over=" + d_moveover
'$app s_out, ", to=" + d_moveto
'$app s_out, ", delta=" + d_delta
'$out s_out
s_solution2 = s_solution1 + ", "
$app s_solution2, d_movefrom + "-"
$app s_solution2, d_moveto
'sg_pass1 = s_board2
'dg_pass1 = d_ply2
'sub_jumpover_board
sg_pass1 = s_board2
sg_pass2 = s_solution2
dg_pass1 = d_ply2
dg_pass2 = d_totalct
dg_pass3 = d_winct
sub_jumpover_move
d_totalct = dg_pass2
d_winct = dg_pass3
dift d_ply2 > 12
dinc d_winct
$cut s_out, s_solution2, 1, 64
$out s_out
$cut s_out, s_solution2, 65, 99999
$out s_out
'$inp s_any, "look"
endi
endi
endi
dinc d_xdelta
endw
endi
dinc d_xmovefrom
endw
dift d_ynmove <> 1
dinc d_totalct
sg_pass1 = s_board1
dg_pass1 = d_ply1
sub_jumpover_board
endi
dg_pass2 = d_totalct
dg_pass3 = d_winct
ends sub_jumpover_move
subr sub_jumpover_board
'updated 2002/05/20
vari d_any, s_any, d_dot, s_dot, s_out
vari s_board, s_alpha, d_col, s_col
vari d_ply, s_dashes
s_board = sg_pass1
d_ply = dg_pass1
$ch$ s_dashes, "-", 50
$out s_dashes
$out "ply=" + d_ply
s_alpha = "abcde"
d_col = 1
d_dot = 111
dwhi d_dot < 159
$cut s_col, s_alpha, d_col, 1
$cut s_out, s_board, d_dot, 10
$out s_col + " " + s_out
d_dot = d_dot + 10
dinc d_col
endw
$out " 123456789"
$out s_dashes
ends sub_jumpover_board
subr sub_hands_main
'find high hands
vari d_any, s_any, d_dot, s_dot
vari d_loop, d_ptr, d_card, d_oldvalue, d_newvalue, s_line
vari s_blanks, d_count, s_newhand, s_oldhand
d_count = 0
s_oldhand = "Nothing"
d_oldvalue = -99999
d_loop = 1
dwhi d_loop = 1
dinc d_count
sub_shuffle
'move from 1/5 to 101/105
d_dot = 1
dwhi d_dot <= 5
d_ptr = d_dot
itod d_card, d_ptr
d_ptr = d_dot + 100
dtoi d_ptr, d_card
dinc d_dot
endw
'evaluate them
dg_round = 5
sub_evaluate2
d_newvalue = dg_pass1
s_newhand = sg_pass1
dift d_newvalue > d_oldvalue
d_oldvalue = d_newvalue
s_oldhand = s_newhand
'put from 101/105 into 131/135
d_dot = 1
dwhi d_dot <= 5
d_ptr = d_dot + 100
itod d_card, d_ptr
d_ptr = d_dot + 130
dtoi d_ptr, d_card
dinc d_dot
endw
endi
'new is in 101/105, old is in 131/135
$ch$ s_blanks, " ", 20
d_dot = 1
dwhi d_dot <= 5
'show new card
d_ptr = d_dot + 100
itod d_card, d_ptr
dg_pass1 = d_card
sub_card_to_string
s_line = sg_pass1
'show old card
d_ptr = d_dot + 130
itod d_card, d_ptr
dg_pass1 = d_card
sub_card_to_string
$app s_line, s_blanks + sg_pass1
$out s_line
dinc d_dot
endw
'show information
s_any = "count=" + d_count + ", value=" + d_oldvalue
$app s_any, ", " + s_oldhand
$out s_any
$ch$ s_any, "*", 70
$out s_any
endw
ends sub_hands_main
subr sub_teacard
'updated 2002/11/10
vari d_any, s_any, d_dot, s_dot
vari d_loop
dg_hand = 0
dg_cmarbles = 1000
dg_pmarbles = 1000
d_loop = 1
dwhi d_loop = 1
dinc dg_hand
sub_shuffle
sub_deal
sub_play_hand
dift dg_cmarbles <= 0
$inp s_any, "You have broken the Computer's bank."
dinc d_loop
endi
dift dg_pmarbles <= 0
$inp s_any, "The Computer has cleaned you out."
dinc d_loop
endi
dift d_loop = 1
$inp s_any, "1 = Another hand, 2 = stop"
$ift s_any <> "1": dinc d_loop
endi
endw
ends sub_teacard
subr sub_play_hand
vari d_any, s_any, d_dot, s_dot
vari d_loop
dg_round = 0
'ante up
ddec dg_pmarbles
ddec dg_cmarbles
dg_pot = 2
dg_continue = 1
dwhi dg_continue = 1
dinc dg_round
dift dg_round > 5: dg_round = 5
dg_playing = 1
sub_show_situation
dift dg_round = 5
dift dg_tvalue > 0
$out "The Computer wins."
dg_cmarbles = dg_cmarbles + dg_pot
else
$out "You win."
dg_pmarbles = dg_pmarbles + dg_pot
endi
sub_show_score
dinc dg_continue
dinc dg_playing
endi
dg_bet = 1
dwhi dg_playing = 1
sub_show_situation
dift dg_tvalue > 0
sub_computer_plays
dinc dg_bet
dift dg_playing = 1: sub_person_plays
else
sub_person_plays
dinc dg_bet
dift dg_playing = 1: sub_computer_plays
endi
endw
endw
ends sub_play_hand
subr sub_person_plays
vari d_any, s_any, d_dot, s_dot
dift dg_craise > 0
$out "You can call by entering " + dg_craise
s_any = "Enter your call amount plus any raise or * to fold"
$inp s_any, s_any
$isd d_any, s_any
dift d_any <> 1
$out "The Computer wins."
dg_cmarbles = dg_cmarbles + dg_pot
sub_show_score
dinc dg_continue
dinc dg_playing
else
$tod d_any, s_any
dift d_any > dg_craise
'person sees and raises
dg_pmarbles = dg_pmarbles - d_any
dg_pot = dg_pot + d_any
dg_praise = d_any - dg_craise
$out "You have raised by " + dg_praise
else
'person calls
dg_pmarbles = dg_pmarbles - dg_craise
dg_pot = dg_pot + dg_craise
dg_praise = 0
dinc dg_playing
endi
endi
endi
dift dg_craise = 0
dift dg_bet = 1
$out "It is your bet."
endi
s_any = "You can call by entering 0 or you can raise."
$inp s_any, s_any
$isd d_any, s_any
dift d_any <> 1: s_any = "0"
$tod d_any, s_any
dift d_any > 0
'person raised
dg_pmarbles = dg_pmarbles - d_any
dg_pot = dg_pot + d_any
dg_praise = d_any
$out "You have raised by " + dg_praise
else
'person called
dg_praise = 0
dinc dg_playing
endi
endi
ends sub_person_plays
subr sub_computer_plays
dift dg_tvalue > 0
dg_craise = 10
dg_cmarbles = dg_cmarbles - dg_praise - dg_craise
dg_pot = dg_pot + dg_praise + dg_craise
dift dg_praise > 0
$out "The Computer sees your raise and raises by " + dg_craise
else
$out "The Computer raises by " + dg_craise
endi
else
dift dg_tvalue > -1000
dg_craise = 0
dg_cmarbles = dg_cmarbles - dg_praise - dg_craise
dg_pot = dg_pot + dg_praise + dg_craise
dinc dg_playing
dift dg_praise > 0
$out "The Computer sees your raise and calls"
else
$out "The Computer calls"
endi
else
dg_pmarbles = dg_pmarbles + dg_pot
$out "The Computer folds."
sub_show_score
dinc dg_playing
dinc dg_continue
endi
endi
ends sub_computer_plays
subr sub_show_situation
vari d_any, s_any, d_dot, s_dot
vari s_line, d_card, s_card, s_blanks, s_dashes
sub_evaluate1
$ch$ s_dashes, "-", 70
$ch$ s_blanks, " ", 20
'show pot amount
$out s_dashes
$out "Hand = "+dg_hand+", Round = "+dg_round
$out "Computer value = " + dg_cvalue + ", Person Value = "+dg_pvalue
$out "Computer total value = " + dg_tvalue
$out s_dashes
$out "Pot = " + dg_pot
$out s_dashes
'show cards
sub_show_hands
'show marbles
sub_show_score
ends sub_show_situation
subr sub_show_hands
vari d_any, s_any, d_dot, s_dot
vari d_card, s_line, d_count, s_blanks
$ch$ s_blanks, " ", 20
$out "computer's cards" + s_blanks + "person's cards"
'sort showing cards
dg_pass1 = 61
dg_pass2 = 60 + dg_round
sub_sort_darray
dg_pass1 = 71
dg_pass2 = 70 + dg_round
sub_sort_darray
d_count = 1
dwhi d_count <= dg_round
'computer
d_any = d_count + 60
itod d_card, d_any
dg_pass1 = d_card
sub_card_to_string
s_line = sg_pass1
'person
d_any = d_count + 70
itod d_card, d_any
dg_pass1 = d_card
sub_card_to_string
$app s_line, s_blanks + sg_pass1
$out s_line
dinc d_count
endw
ends sub_show_hands
subr sub_evaluate1
vari d_any, s_any, d_dot, s_dot
vari d_card, d_ptr
'8000 = straight flush
'7000 = four of a kind
'6000 = full house
'5000 = flush
'4000 = straight
'3000 = three of a kind
'2000 = two pair
'1000 = one pair
'0000 = high card
'do the computer first, put in 101/105 from 61/65
d_dot = 1
dwhi d_dot <= 5
dift d_dot <= dg_round
d_ptr = 60 + d_dot
itod d_card, d_ptr
d_ptr = 100 + d_dot
dtoi d_ptr, d_card
else
d_ptr = 100 + d_dot
dtoi d_ptr, 0
endi
dinc d_dot
endw
sub_evaluate2
dg_cvalue = dg_pass1
'person, put in 101/105 from 71/75
d_dot = 1
dwhi d_dot <= 5
dift d_dot <= dg_round
d_ptr = 70 + d_dot
itod d_card, d_ptr
d_ptr = 100 + d_dot
dtoi d_ptr, d_card
else
d_ptr = 100 + d_dot
dtoi d_ptr, 0
endi
dinc d_dot
endw
sub_evaluate2
dg_pvalue = dg_pass1
dg_tvalue = dg_cvalue - dg_pvalue
ends sub_evaluate1
subr sub_evaluate2
'evaluate cards in 101/105, put value in dg_pass1
vari d_any, s_any, d_dot, s_dot, d_ptr
vari d_flush, d_straight
vari d_four, d_fullhouse, d_three, d_twopair, d_pair
vari d_number, d_suit, d_card, d_count, s_hand
vari d_index1, d_index2, d_value
d_value = 0
s_hand = "High Card"
'8000 = straight flush
'7000 = four of a kind
'6000 = full house
'5000 = flush
'4000 = straight
'3000 = three of a kind
'2000 = two pair
'1000 = one pair
'0000 = high card
'sort with larger at top
dg_pass1 = 101
dg_pass2 = 105
sub_sort_darray
'which hand do we have
d_flush = 0
d_straight = 0
d_four = 0
d_fullhouse = 0
d_three = 0
d_twopair = 0
d_pair = 0
'do we have a flush or a straight
dift dg_round >= 5
'which straight and which flush are we looking for
dg_pass1 = 101
sub_which_card
d_straight = dg_pass1
d_flush = dg_pass2
d_card = d_straight
d_ptr = 102
dwhi d_ptr <= 105
'the highest numbered card is in 101
ddec d_card
'which card do we now have
dg_pass1 = d_ptr
sub_which_card
d_number = dg_pass1
d_suit = dg_pass2
dift d_number <> d_card: d_straight = 0
dift d_suit <> d_flush: d_flush = 0
dinc d_ptr
endw
endi
'initialize
d_ptr = 111
dwhi d_ptr <= 124
dtoi d_ptr, 0
dinc d_ptr
endw
d_value = 0
d_dot = 1
dwhi d_dot <= 5
dg_pass1 = d_dot + 100
sub_which_card
d_number = dg_pass1
d_suit = dg_pass2
'build up the high card d_value
d_value = d_value * 14 + d_number
'112/124 will have how many of each kind of card in them
d_ptr = 110 + d_number
itod d_any, d_ptr
dinc d_any
dtoi d_ptr, d_any
dinc d_dot
endw
'analyze to see how many of each card
d_ptr = 112
dwhi d_ptr <= 124
itod d_count, d_ptr
d_card = d_ptr - 110
'four of a kind
dift d_count = 4: d_four = d_card
'three of a kind
dift d_count = 3: d_three = d_card
'pair
dift d_count = 2
dift d_pair > 0
d_twopair = d_card
else
d_pair = d_card
endi
endi
dinc d_ptr
endw
d_value = d_value / 1000 / 1000
'8000 = straight flush
'7000 = four of a kind
'6000 = full house
'5000 = flush
'4000 = straight
'3000 = three of a kind
'2000 = two pair
'1000 = one pair
'0000 = high card
'do we have a flush or a straight flush
dift d_flush > 0
dift d_straight > 0
s_hand = "Straight Flush"
d_value = 10 * d_straight + d_value + 8000 + d_flush
else
s_hand = "Flush"
d_value = d_value + 5000 + d_flush
endi
d_straight = 0
endi
'do we have only a straight
dift d_straight > 0
d_value = d_value + 4000 + d_straight
s_hand = "Straight"
endi
'do we have four of a kind
dift d_four > 0
'four of a kind
d_value = d_value + 7000 + d_four
s_hand = "Four of a Kind"
d_three = 0
d_pair = 0
endi
'do we have three of a kind or a full house
dift d_three > 0
dift d_pair > 0
'full house
d_value = d_value + 6000 + d_three
s_hand = "Full House"
else
'three of a kind
d_value = d_value + 3000 + d_three
s_hand = "Three of a Kind"
endi
d_pair = 0
endi
'do we have one pair or perhaps two
dift d_pair > 0
dift d_twopair > 0
'two pair
d_value = d_value + 2000 + d_twopair
s_hand = "Two Pair"
else
'one pair
d_value = d_value + 1000 + d_pair
s_hand = "One Pair"
endi
endi
sg_pass1 = s_hand
dg_pass1 = d_value
ends sub_evaluate2
subr sub_show_score
vari d_any, s_any, d_dot, s_dot, s_dashes
$ch$ s_dashes, "-", 70
'show marbles
$out s_dashes
dto$ s_any, dg_cmarbles, 10, 0
dto$ s_dot, dg_pmarbles, 10, 0
$out "computer=" + s_any + " person=" + s_dot
$out s_dashes
ends sub_show_score
subr sub_deal
vari d_ptrfrom, d_ptrto, d_card, d_count
d_ptrfrom = 0
d_count = 1
dwhi d_count <= 5
dinc d_ptrfrom
itod d_card, d_ptrfrom
d_ptrto = d_count + 60
dtoi d_ptrto, d_card
dinc d_ptrfrom
itod d_card, d_ptrfrom
d_ptrto = d_count + 70
dtoi d_ptrto, d_card
dinc d_count
endw
ends sub_deal
subr sub_shuffle
'build up a deck of cards in 1/52 and shuffle
vari d_any, s_any, d_dot, s_dot
vari d_ptr, d_card, s_card, d_count, d_number, d_suit
'load the deck
d_count = 0
d_ptr = 1
dwhi d_ptr <= 52
'get the suit into d_suit
d_any = d_ptr - 1
d_suit = d_any % 4
dinc d_suit
'get the number into d_number
d_any = d_ptr - 1 / 4
d_any = d_any \ 1
d_number = d_any + 2 * 10
d_card = d_number + d_suit
dtoi d_ptr, d_card
dg_pass1 = d_card
sub_card_to_string
s_card = sg_pass1
dinc d_count
dift d_count > 7
'$inp s_any, "return"
d_count = 1
endi
'$out "pointer= " + d_ptr + ", card=" + d_card + " " + s_card
dinc d_ptr
endw
'now to shuffle
$out "shuffling"
d_count = 0
dwhi d_count < 100
d_ptr = 1
dwhi d_ptr <= 52
dran d_any
d_any = d_any * 52 + 1
'switch the two cards
itod d_dot, d_any
itod d_card, d_ptr
dtoi d_ptr, d_dot
dtoi d_any, d_card
dinc d_ptr
endw
dinc d_count
endw
ends sub_shuffle
subr sub_card_to_string
'change card number to string showing what the card is
vari s_any
vari d_card, d_number, s_number, d_suit, s_suit, s_line
d_card = dg_pass1
d_suit = d_card % 10
dift d_suit = 1: s_suit = "Diamonds"
dift d_suit = 2: s_suit = "Clubs"
dift d_suit = 3: s_suit = "Hearts"
dift d_suit = 4: s_suit = "Spades"
d_number = d_card / 10
d_number = d_number \ 1
s_number = d_number
dift d_number = 11: s_number = "Jack"
dift d_number = 12: s_number = "Queen"
dift d_number = 13: s_number = "King"
dift d_number = 14: s_number = "Ace"
s_line = " " + s_number + "." + s_suit + " "
$cut s_line, s_line, 1, 16
dto$ s_any, d_card, 4, 0
$app s_line, s_any
sg_pass1 = s_line
ends sub_card_to_string
subr sub_show_deck
vari d_any, s_any, d_dot, s_dot
vari d_ptr, d_count, s_card
d_count = 0
d_ptr = 1
dwhi d_ptr <= 52
itod d_any, d_ptr
dg_pass1 = d_any
sub_card_to_string
s_card = sg_pass1
dinc d_count
dift d_count > 7
$inp s_any, "return"
d_count = 1
endi
$out s_card
dinc d_ptr
endw
ends sub_show_deck
subr sub_sort_darray
'sort cards from pointers dg_pass1 to dg_pass2
vari d_end, d_index1, d_index2, d_card1, d_card2
d_index1 = dg_pass1
d_end = dg_pass2
dwhi d_index1 < d_end
d_index2 = d_index1 + 1
dwhi d_index2 <= d_end
itod d_card1, d_index1
itod d_card2, d_index2
dift d_card2 > d_card1
dtoi d_index1, d_card2
dtoi d_index2, d_card1
endi
dinc d_index2
endw
dinc d_index1
endw
ends sub_sort_darray
subr sub_which_card
'which card do we have pointed to by dg_pass1
'put number in dg_pass1 and suit in dg_pass2
vari d_ptr, d_card, d_number, d_suit
d_ptr = dg_pass1
itod d_card, d_ptr
d_suit = d_card % 10
d_number = d_card / 10
d_number = d_number \ 1
dg_pass1 = d_number
dg_pass2 = d_suit
ends sub_which_card
subr sub_TeaProperty
'main subroutine
vari d_loop, s_inp
$out "Program = TeaProperty.tea, version = 18-NOV-1999"
$out "Written by D La Pierre Ballard using the new language"
$out "TeaPro (c) 1997-2000 D La Pierre Ballard"
$out "Begun on 02-JAN-1999"
sub_initialize_TeaProperty
sub_board_TeaProperty
$inp s_inp, "1 = automatic"
$ift s_inp = "1": dg_auto = 1
d_loop = 1
dwhi d_loop = 1
sub_get_pmove
$ift sg_pass1 = "*": dinc d_loop
dift dg_pmoney < 0: sub_psell_to_bank
dift dg_pmoney < 0
$inp s_inp, "The Person loses"
dinc d_loop
endi
dift d_loop = 1
sub_get_cmove
$ift sg_pass1 = "*": dinc d_loop
dift dg_cmoney < 0: sub_csell_to_bank
dift dg_cmoney < 0
$inp s_inp, "The Computer loses"
dinc d_loop
endi
endi
endw
ends sub_TeaProperty
subr sub_initialize_TeaProperty
'initialize
vari d_any, s_any, d_dot, s_dot
vari d_ptr, d_count, s_line
dg_ploc = 40
dg_cloc = 40
dg_pmoney = 1500
dg_cmoney = 1500
sg_change = ", Starting out"
dg_bankct = 28
dg_auto = 2
dg_coutofjailfree = 2
dg_poutofjailfree = 2
$toi 1, "Mediterranean Ave, 60, 2,1"
$toi 2, "Community Chest ,0"
$toi 3, "Baltic Avenue, 60, 4,1"
$toi 4, "Pay Bank $200 ,0"
$toi 5, "Reading Railroad, 200, 25,1"
$toi 6, "Oriental Avenue, 100, 6,1"
$toi 7, "Chance ,0"
$toi 8, "Vermont Avenue, 100, 6,1"
$toi 9, "Connecticut Ave, 120, 8,1"
$toi 10, "Visiting the Jail ,0"
$toi 11, "St. Charles Place, 140, 10,1"
$toi 12, "Electric Company, 150, 28,1"
$toi 13, "States Avenue, 140, 10,1"
$toi 14, "Virginia Avenue, 160, 12,1"
$toi 15, "Pennsylvania RR 200, 25,1"
$toi 16, "St. James Place, 180, 14,1"
$toi 17, "Community Chest ,0"
$toi 18, "Tennessee Avenue, 180, 14,1"
$toi 19, "New York Avenue, 200, 16,1"
$toi 20, "Free Parking ,0"
$toi 21, "Kentucky Avenue, 220, 18,1"
$toi 22, "Chance ,0"
$toi 23, "Indiana Avenue, 220, 18,1"
$toi 24, "Illinois Avenue, 240, 20,1"
$toi 25, "B. & O. Railroad, 200, 25,1"
$toi 26, "Atlantic Avenue, 260, 22,1"
$toi 27, "Ventnor Avenue, 260, 22,1"
$toi 28, "Water Works, 150, 28,1"
$toi 29, "Marvin Gardens, 280, 24,1"
$toi 30, "Go To Jail ,0"
$toi 31, "Pacific Avenue, 300, 26,1"
$toi 32, "North Carolina Ave,300, 26,1"
$toi 33, "Community Chest ,0"
$toi 34, "Pennsylvania Ave, 320, 28,1"
$toi 35, "Short Line RR, 200, 25,1"
$toi 36, "Chance ,0"
$toi 37, "Park Place, 350, 35,1"
$toi 38, "Pay Bank $75 ,0"
$toi 39, "Boardwalk, 400, 50,1"
$toi 40, "Go, Collect $200 ,0"
' 123456789012345678901234567890
d_count = 1
dwhi d_count <= 40
d_ptr = d_count
ito$ s_line, d_ptr
'ownership 1 to 40
$cut s_dot, s_line, 28, 1
$tod d_dot, s_dot
d_ptr = d_count
dtoi d_ptr, d_dot
'rent 101 to 140
$cut s_dot, s_line, 25, 2
$ift s_dot = " ": s_dot = "0"
$tod d_dot, s_dot
d_ptr = d_count + 100
dtoi d_ptr, d_dot
'price 201 to 240
$cut s_dot, s_line, 20, 3
$ift s_dot = " ": s_dot = "0"
$tod d_dot, s_dot
d_ptr = d_count + 200
dtoi d_ptr, d_dot
$cut s_line, s_line, 1, 26
d_ptr = d_count
$toi d_ptr, s_line
dinc d_count
endw
ends sub_initialize_TeaProperty
subr sub_board_TeaProperty
'show the board
vari d_any, s_any, d_dot, s_dot
vari d_ptr, s_out, d_count, s_line, s_ploc, s_cloc
vari d_own, s_own
'owner 1 to 40, 1=bank, 2=computer, 3=person
'rent 101 to 140
'price 201 to 240
s_own = "."
s_out = " # Property Price Rt O C P"
$app s_out, " " + s_out
$out s_out
d_count = 1
dwhi d_count <= 20
d_ptr = d_count
'who owns this one
s_own = "."
itod d_own, d_ptr
dift d_own = 2: s_own = "C"
dift d_own = 3: s_own = "P"
'are either men on this
dift dg_ploc = d_ptr
s_ploc = "P"
else
s_ploc = "."
endi
dift dg_cloc = d_ptr
s_cloc = "C"
else
s_cloc = "."
endi
ito$ s_line, d_ptr
dto$ s_any, d_count, 2, 0
s_out = s_any + " " + s_line + " "
dch$ sg_32, 32, 50
$app s_out, s_own + " " + s_cloc + " " + s_ploc + sg_32
$cut s_out, s_out, 1, 35
'******************************************
d_ptr = d_count + 20
'who owns this one
s_own = "."
itod d_own, d_ptr
dift d_own = 2: s_own = "C"
dift d_own = 3: s_own = "P"
'are either men on this
dift dg_ploc = d_ptr
s_ploc = "P"
else
s_ploc = "."
endi
dift dg_cloc = d_ptr
s_cloc = "C"
else
s_cloc = "."
endi
ito$ s_line, d_ptr
d_any = d_count + 20
dto$ s_any, d_any, 2, 0
$app s_out, " " + s_any + " " + s_line + " "
dch$ sg_32, 32, 80
$app s_out, s_own + " " + s_cloc + " " + s_ploc + sg_32
$cut s_out, s_out, 1, 76
$out s_out
dinc d_count
endw
$out sg_card
sg_card = ""
'output money line
s_out = "Computer money=$" + dg_cmoney + ", Person money=$"
$out s_out + dg_pmoney + sg_change
sg_change = ""
ends sub_board_TeaProperty
subr sub_get_cmove
'get the computer move
vari d_any, s_any
$out "THE COMPUTER MOVES"
sub_dice
dift dg_cloc = 40: dg_cloc = 0
dg_cloc = dg_cloc + dg_dice1 + dg_dice2
dift dg_bankct > 0
dift dg_cloc >= 40
dg_cmoney = dg_cmoney + 200
sg_change = ", Computer passes Go"
endi
endi
dift dg_cloc > 40: dg_cloc = dg_cloc - 40
sub_cmove_changes
dift dg_auto = 1
sub_pause
else
$inp s_any, "The Computer has moved, * to end"
endi
sg_pass1 = s_any
ends sub_get_cmove
subr sub_get_pmove
'get the person move
vari s_input
$out "THE PERSON MOVES"
sub_dice
dift dg_ploc = 40: dg_ploc = 0
dg_ploc = dg_ploc + dg_dice1 + dg_dice2
dift dg_bankct > 0
dift dg_ploc >= 40
dg_pmoney = dg_pmoney + 200
sg_change = ", Person passes Go"
endi
endi
dift dg_ploc > 40: dg_ploc = dg_ploc - 40
sub_pmove_changes
dift dg_auto = 1
sub_pause
else
$inp s_input, "The Person has moved, * to end"
endi
sg_pass1 = s_input
ends sub_get_pmove
subr sub_cmove_changes
'changes by the computer move
vari d_any, s_any, d_tad, s_tad, d_good
vari d_ptr, d_owner, d_price, d_rent
'owner 1 to 40, 1=bank, 2=computer, 3=person
'rent 101 to 140
'price 201 to 240
'get the information
'get the owner
d_ptr = dg_cloc
itod d_owner, d_ptr
'get the rent
d_ptr = dg_cloc + 100
itod d_rent, d_ptr
'get the price
d_ptr = dg_cloc + 200
itod d_price, d_ptr
s_any = ", Owner="+d_owner+", Rent="+d_rent+", Price="+d_price
$out sg_dice + s_any
'if the bank owns it
dift d_owner = 1
'buy it if we can have at least 300 left over
d_any = dg_cmoney - d_price
dift d_any >= 300
dg_cmoney = dg_cmoney - d_price
sg_change = ", Computer buys for=$" + d_price
d_ptr = dg_cloc
dtoi d_ptr, 2
ddec dg_bankct
endi
endi
'if the person owns it
dift d_owner = 3
'give the person the amount of rent
dg_pmoney = dg_pmoney + d_rent
dg_cmoney = dg_cmoney - d_rent
sg_change = ", Computer pays rent=$" + d_rent
endi
'if it is a special spot
dift d_owner = 0
'do we have Chance
d_good = 2
dift dg_cloc = 7: d_good = 1
dift dg_cloc = 22: d_good = 1
dift dg_cloc = 36: d_good = 1
dift d_good = 1: sub_cchance
'do we have Community Chest
d_good = 2
dift dg_cloc = 2: d_good = 1
dift dg_cloc = 17: d_good = 1
dift dg_cloc = 33: d_good = 1
dift d_good = 1: sub_ccommunity_chest
'tax of $200
dift dg_cloc = 4
dg_cmoney = dg_cmoney - 200
sg_change = ", Computer pays tax=$200"
endi
'tax of $75
dift dg_cloc = 38
dg_cmoney = dg_cmoney - 75
sg_change = ", Computer pays tax=$75"
endi
'go to jail
dift dg_cloc = 30
dg_cmoney = dg_cmoney - 50
sg_change = ", Computer gets out of jail=$50"
dg_cloc = 10
endi
endi
sub_board_TeaProperty
ends sub_cmove_changes
subr sub_pmove_changes
'changes by the person move
vari d_any, s_any, d_good
vari d_ptr, d_owner, d_price, d_rent, d_boardshow
d_boardshow = 1
'owner 1 to 40, 1=bank, 2=computer, 3=person
'rent 101 to 140
'price 201 to 240
'get the information
'get the owner
d_ptr = dg_ploc
itod d_owner, d_ptr
'get the rent
d_ptr = dg_ploc + 100
itod d_rent, d_ptr
'get the price
d_ptr = dg_ploc + 200
itod d_price, d_ptr
s_any = ", Owner="+d_owner+", Rent="+d_rent+", Price="+d_price
$out sg_dice + s_any
'if the bank owns it
dift d_owner = 1
d_any = dg_pmoney - d_price
dift d_any >= 0
sub_board_TeaProperty
dinc d_boardshow
$inp s_any, "1 = buy it"
$ift s_any = "1"
dg_pmoney = dg_pmoney - d_price
d_ptr = dg_ploc
dtoi d_ptr, 3
sg_change = ", Person buys for=$" + d_price
ddec dg_bankct
endi
endi
endi
'if the computer owns it
dift d_owner = 2
'give the computer the amount of rent
dg_cmoney = dg_cmoney + d_rent
dg_pmoney = dg_pmoney - d_rent
sg_change = ", Person pays rent=$" + d_rent
endi
'if it is a special spot
dift d_owner = 0
'do we have Chance
d_good = 2
dift dg_ploc = 7: d_good = 1
dift dg_ploc = 22: d_good = 1
dift dg_ploc = 36: d_good = 1
dift d_good = 1: sub_pchance
'do we have Community Chest
d_good = 2
dift dg_ploc = 2: d_good = 1
dift dg_ploc = 17: d_good = 1
dift dg_ploc = 33: d_good = 1
dift d_good = 1: sub_pcommunity_chest
'tax of $200
dift dg_ploc = 4
dg_pmoney = dg_pmoney - 200
sg_change = ", Person pays tax=$200"
endi
'tax of $75
dift dg_ploc = 38
dg_pmoney = dg_pmoney - 75
sg_change = ", Person pays tax=$75"
endi
'go to jail
dift dg_ploc = 30
dg_pmoney = dg_pmoney - 50
sg_change = ", Person gets out of jail=$50"
dg_ploc = 10
endi
endi
dift d_boardshow = 1: sub_board_TeaProperty
ends sub_pmove_changes
subr sub_csell_to_bank
'computer property to bank
vari d_index
'owner 1 to 40, 1=bank, 2=computer, 3=person
'rent 101 to 140
'price 201 to 240
d_index = 0
ends sub_csell_to_bank
subr sub_psell_to_bank
'person property to bank
ends sub_psell_to_bank
subr sub_cchance
'Computer takes a Chance
vari d_take, d_any, s_any
dsec d_take
d_take = d_take / 7
d_take = d_take % 16
dinc d_take
dift d_take = 1
sg_card = "Bank Pays You Dividend of $50"
dg_cmoney = dg_cmoney + 50
endi
dift d_take = 2
sg_card = "Your Loan Matures collect $150"
dg_cmoney = dg_cmoney + 150
endi
dift d_take = 3
sg_card = "Elected Chairman pay person $50"
dg_cmoney = dg_cmoney - 50
dg_pmoney = dg_pmoney + 50
endi
dift d_take = 4
sg_card = "Pay Poor Tax of $15"
dg_cmoney = dg_cmoney - 15
endi
dift d_take = 5: sg_card = "Pay $25/house, $100/hotel"
dift d_take = 6
sg_card = "Advance token to Go collect $200"
dg_cloc = 40
dg_cmoney = dg_cmoney + 200
endi
dift d_take = 7
sg_card = "Get Out Of Jail Free"
dg_coutofjailfree = 1
endi
dift d_take = 8
sg_card = "Go Directly To Jail"
dg_cmoney = dg_cmoney - 50
dg_cloc = 10
endi
dift d_take = 9
sg_card = "Advance To St. Charles Place, if Go collect $200"
dift dg_cloc > 10: dg_cmoney = dg_cmoney + 200
dg_cloc = 11
endi
dift d_take = 10
sg_card = "Advance To Illinois Ave"
dg_cloc = 24
endi
dift d_take = 11
sg_card = "Advance To Board Walk"
dg_cloc = 39
endi
dift d_take = 12
sg_card = "Take A Ride On The Reading, if Go collect $200"
dift dg_cloc > 5: dg_cmoney = dg_cmoney + 200
dg_cloc = 5
endi
dift d_take = 13
sg_card = "Go Back Three Spaces"
dg_cloc = dg_cloc - 3
dift dg_cloc < 1: dg_cloc = dg_cloc + 40
endi
'5,15,25,35
'advance to nearest RR pay twice
'advance to nearest RR pay twice
dift d_take = 14: d_take = 15
dift d_take = 15
dift dg_cloc > 35: d_any = 5
dift dg_cloc > 25: d_any = 35
dift dg_cloc > 15: d_any = 25
dift dg_cloc > 5: d_any = 10
dg_cloc = d_any
endi
'advance to nearest utility pay $70
'12,28
dift d_take = 16
d_any = 28
dift dg_cloc > 28: d_any = 12
dg_cloc = d_any
endi
ends sub_cchance
subr sub_pchance
'Person takes a Chance
vari d_take, d_any, s_any
dsec d_take
d_take = d_take / 7
d_take = d_take % 16
dinc d_take
dift d_take = 1
sg_card = "Bank Pays You Dividend of $50"
dg_pmoney = dg_pmoney + 50
endi
dift d_take = 2
sg_card = "Your Loan Matures collect $150"
dg_pmoney = dg_pmoney + 150
endi
dift d_take = 3
sg_card = "Elected Chairman pay person $50"
dg_pmoney = dg_pmoney - 50
dg_cmoney = dg_cmoney + 50
endi
dift d_take = 4
sg_card = "Pay Poor Tax of $15"
dg_pmoney = dg_pmoney - 15
endi
dift d_take = 5: sg_card = "Pay $25/house, $100/hotel"
dift d_take = 6
sg_card = "Advance token to Go collect $200"
dg_ploc = 40
dg_pmoney = dg_pmoney + 200
endi
dift d_take = 7
sg_card = "Get Out Of Jail Free"
dg_coutofjailfree = 1
endi
dift d_take = 8
sg_card = "Go Directly To Jail"
dg_pmoney = dg_pmoney - 50
dg_ploc = 10
endi
dift d_take = 9
sg_card = "Advance To St. Charles Place, if Go collect $200"
dift dg_ploc > 10: dg_pmoney = dg_pmoney + 200
dg_ploc = 11
endi
dift d_take = 10
sg_card = "Advance To Illinois Ave"
dg_ploc = 24
endi
dift d_take = 11
sg_card = "Advance To Board Walk"
dg_ploc = 39
endi
dift d_take = 12
sg_card = "Take A Ride On The Reading, if Go collect $200"
dift dg_ploc > 5: dg_pmoney = dg_pmoney + 200
dg_ploc = 5
endi
dift d_take = 13
sg_card = "Go Back Three Spaces"
dg_ploc = dg_ploc - 3
dift dg_ploc < 1: dg_ploc = dg_ploc + 40
endi
'5,15,25,35
'advance to nearest RR pay twice
'advance to nearest RR pay twice
dift d_take = 14: d_take = 15
dift d_take = 15
dift dg_ploc > 35: d_any = 5
dift dg_ploc > 25: d_any = 35
dift dg_ploc > 15: d_any = 25
dift dg_ploc > 5: d_any = 10
dg_ploc = d_any
endi
'advance to nearest utility pay $70
'12,28
dift d_take = 16
d_any = 28
dift dg_ploc > 28: d_any = 12
dg_ploc = d_any
endi
ends sub_pchance
subr sub_ccommunity_chest
'take a Community Chest card
vari d_take, d_any, s_any
dsec d_take
d_take = d_take / 7
d_take = d_take % 16
dinc d_take
dift d_take = 1
sg_card = "Income Tax Refund Collect $20"
dg_cmoney = dg_cmoney + 20
endi
dift d_take = 2
sg_card = "You Inherit $100"
dg_cmoney = dg_cmoney + 100
endi
dift d_take = 3
sg_card = "2nd Prize, Beauty Contest $10"
dg_cmoney = dg_cmoney + 10
endi
dift d_take = 4
sg_card = "Bank Error Collect $200"
dg_cmoney = dg_cmoney + 200
endi
dift d_take = 5
sg_card = "Opera Opening collect $50 from Person"
dg_cmoney = dg_cmoney + 50
dg_pmoney = dg_pmoney - 50
endi
dift d_take = 6
sg_card = "From Sale of Stock collect $45"
dg_cmoney = dg_cmoney + 45
endi
dift d_take = 7
sg_card = "Life Insurance collect $100"
dg_cmoney = dg_cmoney + 100
endi
dift d_take = 8
sg_card = "Christmas Fund, collect $100"
dg_cmoney = dg_cmoney + 100
endi
dift d_take = 9
sg_card = "Receive For Services $25"
dg_cmoney = dg_cmoney + 25
endi
dift d_take = 10
sg_card = "Doctor's Fee pay $50"
dg_cmoney = dg_cmoney - 50
endi
dift d_take = 11
sg_card = "Pay School Tax of $150"
dg_cmoney = dg_cmoney - 150
endi
dift d_take = 12
sg_card = "Pay Hospital $100"
dg_cmoney = dg_cmoney - 100
endi
dift d_take = 13
sg_card = "Advance To Go, Collect $200"
dg_cmoney = dg_cmoney + 200
dg_cloc = 40
endi
dift d_take = 14
sg_card = "Go Directly To Jail"
dg_cmoney = dg_cmoney - 50
dg_cloc = 10
endi
dift d_take = 15: sg_card = "Pay $40/house and $115/hotel"
dift d_take = 16
sg_card = "Get Out Of Jail Free"
dg_coutofjailfree = 1
endi
ends sub_ccommunity_chest
subr sub_pcommunity_chest
'take a Community Chest card
vari d_take, d_any, s_any
dsec d_take
d_take = d_take / 7
d_take = d_take % 16
dinc d_take
dift d_take = 1
sg_card = "Income Tax Refund Collect $20"
dg_pmoney = dg_pmoney + 20
endi
dift d_take = 2
sg_card = "You Inherit $100"
dg_pmoney = dg_pmoney + 100
endi
dift d_take = 3
sg_card = "2nd Prize, Beauty Contest $10"
dg_pmoney = dg_pmoney + 10
endi
dift d_take = 4
sg_card = "Bank Error Collect $200"
dg_pmoney = dg_pmoney + 200
endi
dift d_take = 5
sg_card = "Opera Opening collect $50 from Person"
dg_pmoney = dg_pmoney + 50
dg_pmoney = dg_pmoney - 50
endi
dift d_take = 6
sg_card = "From Sale of Stock collect $45"
dg_pmoney = dg_pmoney + 45
endi
dift d_take = 7
sg_card = "Life Insurance collect $100"
dg_pmoney = dg_pmoney + 100
endi
dift d_take = 8
sg_card = "Christmas Fund, collect $100"
dg_pmoney = dg_pmoney + 100
endi
dift d_take = 9
sg_card = "Receive For Services $25"
dg_pmoney = dg_pmoney + 25
endi
dift d_take = 10
sg_card = "Doctor's Fee pay $50"
dg_pmoney = dg_pmoney - 50
endi
dift d_take = 11
sg_card = "Pay School Tax of $150"
dg_pmoney = dg_pmoney - 150
endi
dift d_take = 12
sg_card = "Pay Hospital $100"
dg_pmoney = dg_pmoney - 100
endi
dift d_take = 13
sg_card = "Advance To Go, Collect $200"
dg_pmoney = dg_pmoney + 200
dg_ploc = 40
endi
dift d_take = 14
sg_card = "Go Directly To Jail"
dg_pmoney = dg_pmoney - 50
dg_ploc = 10
endi
dift d_take = 15: sg_card = "Pay $40/house and $115/hotel"
dift d_take = 16
sg_card = "Get Out Of Jail Free"
dg_poutofjailfree = 1
endi
ends sub_pcommunity_chest
subr sub_dice
'roll the dice
vari d_any, s_any, d_dot
dsec d_any
d_any = d_any / 7
dg_dice1 = d_any % 6
dinc dg_dice1
d_any = 0
dwhi d_any < 2000
dinc d_any
endw
dsec d_any
d_any = d_any / 13
dg_dice2 = d_any % 6
dinc dg_dice2
d_any = dg_dice1 + dg_dice2
sg_dice = "Dice=" + dg_dice1 + "+" + dg_dice2 + "=" + d_any
ends sub_dice
subr sub_pause
'updated 2005/11/02
'pause a bit
vari d_count, d_bignumber
d_bignumber = 50 * 1000
d_count = 0
dwhi d_count < d_bignumber
dinc d_count
endw
ends sub_pause
subr sub_tea_over_prog
'main subroutine
vari s_any, d_any, s_dot, d_dot
vari s_input, d_loop1, d_loop2, d_good
'initialize
sub_tea_over_initialize
d_loop1 = 1
dwhi d_loop1 = 1
'is there a person move
sg_pass1 = sg_board1
sub_tea_over_existing_moves
d_loop2 = 1
dift dg_existingmovep = 0
dinc d_loop2
$inp s_any, "Person must pass"
$ift s_any = "*": dinc d_loop1
endi
'get the person move
dwhi d_loop2 = 1
'show the board
sg_pass1 = sg_board1
sub_tea_over_board
'input the person move
$inp s_input, "Person moves P"
$trb s_input, s_input
$clo s_input, s_input
$ift s_input = "*"
dinc d_loop1
dinc d_loop2
else
'make the person move
sg_pass1 = s_input
sub_tea_over_pmove
d_good = dg_pass1
dift d_good = 1: dinc d_loop2
endi
endw
dift d_loop1 = 1
'is there a computer move
sg_pass1 = sg_board1
sub_tea_over_existing_moves
dift dg_existingmovec > 0
sub_tea_over_cmove
else
$inp s_any, "Computer must pass"
$ift s_any = "*": dinc d_loop1
endi
endi
'is the play over
sg_pass1 = sg_board1
sub_tea_over_existing_moves
dift dg_existingmovep = 0
dift dg_existingmovec = 0
sub_tea_over_board
$inp s_any, "Play is over"
dinc d_loop1
endi
endi
endw
$inp s_input, "return"
ends sub_tea_over_prog
subr sub_tea_over_initialize
'initialize before continuing
vari d_any
dch$ sg_board1, 32, 100
sg_board1 = sg_board1 + "12345678 "
sg_board1 = sg_board1 + "a--------a"
sg_board1 = sg_board1 + "b--------b"
sg_board1 = sg_board1 + "c--------c"
sg_board1 = sg_board1 + "d---CP---d"
sg_board1 = sg_board1 + "e---PC---e"
sg_board1 = sg_board1 + "f--------f"
sg_board1 = sg_board1 + "g--------g"
sg_board1 = sg_board1 + "h--------h"
sg_board1 = sg_board1 + " 12345678 "
dtoi 1, 1
dtoi 2, -1
dtoi 3, 10
dtoi 4, -10
dtoi 5, 9
dtoi 6, -9
dtoi 7, 11
dtoi 8, -11
'existing moves
dg_existingmovec = 1
dg_existingmovep = 1
ends sub_tea_over_initialize
subr sub_tea_over_board
'output the board
vari s_any, d_any, s_dot, d_dot
vari s_line, d_file, d_rank, s_board
s_board = sg_pass1
d_rank = 9
dwhi d_rank >= 0
s_line = ""
d_file = 0
dwhi d_file <= 10
d_dot = d_file * 10 + d_rank + 100
$cut s_dot, s_board, d_dot, 1
$app s_line, s_dot + " "
dinc d_file
endw
dch$ s_any, 32, 10
$out s_any + s_line
ddec d_rank
endw
'count the men and get the move existing status
sg_pass1 = s_board
sub_tea_over_existing_moves
$out "Computer C count=" + dg_ccount
$out " Person P count=" + dg_pcount
ends sub_tea_over_board
subr sub_tea_over_pmove
'person moves ie. c4
vari s_any, d_any, s_dot, d_dot
vari s_move, d_move, s_alpha, s_numbers, d_good, d_loop
vari d_delta, d_ptr, d_bad
s_move = sg_pass1
s_alpha = "ABCDEFGH"
s_numbers = "12345678"
d_good = 1
$len d_any, s_move
dift d_any <> 2: dinc d_good
dift d_good = 1
'get the move and validate
$cup s_move, s_move
$cut s_any, s_move, 1, 1
$lok d_any, s_alpha, 1, s_any
dift d_any = 0: dinc d_good
$cut s_dot, s_move, 2, 1
$lok d_dot, s_numbers, 1, s_dot
dift d_dot = 0: dinc d_good
d_move = d_any * 10 + d_dot + 100
endi
dift d_good = 1
$cut s_any, sg_board1, d_move, 1
$ift s_any <> "-": dinc d_good
endi
dift d_good = 1
d_bad = 1
d_ptr = 1
dwhi d_ptr <= 8
itod d_delta, d_ptr
'find adjacent place
d_dot = d_move + d_delta
$cut s_dot, sg_board1, d_dot, 1
'does adjacent place have a C
$ift s_dot = "C"
'go through the ray of places with a C
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, sg_board1, d_dot, 1
$ift s_dot <> "C": dinc d_loop
endw
$ift s_dot = "P"
dinc d_bad
'go back through the ray of places with a C
dwhi d_dot <> d_move
d_dot = d_dot - d_delta
$rep sg_board1, d_dot, "P"
endw
endi
endi
dinc d_ptr
endw
dift d_bad = 1: dinc d_good
endi
dg_pass1 = d_good
ends sub_tea_over_pmove
subr sub_tea_over_cmove
'computer moves
vari d_any, s_any, d_dot, s_dot, d_good
vari d_ten, d_one, d_move, d_value0, d_value1, s_board0, s_board1
s_board0 = sg_board1
d_value0 = -1000 * 1000 * 1000
'try out all the moves
d_ten = 10
dwhi d_ten <= 80
d_one = 1
dwhi d_one <= 8
d_move = d_ten + d_one + 100
'make the cmove
dg_pass1 = d_move
sg_pass1 = sg_board1
sub_tea_over_make_cmove
d_good = dg_pass1
s_board1 = sg_pass1
dift d_good = 1
'evaluate the position
sg_pass1 = s_board1
sub_tea_over_cevaluate
d_value1 = dg_pass1
dift d_value1 > d_value0
d_value0 = d_value1
s_board0 = s_board1
endi
endi
dinc d_one
endw
d_ten = d_ten + 10
endw
sg_board1 = s_board0
ends sub_tea_over_cmove
subr sub_tea_over_make_cmove
'make the cmove
vari s_any, d_any, s_dot, d_dot
vari s_move, d_move, s_alpha, s_numbers, d_good, d_loop
vari s_board, d_delta, d_ptr, d_bad
d_move = dg_pass1
s_board = sg_pass1
d_good = 2
$cut s_dot, s_board, d_move, 1
$ift s_dot = "-"
d_ptr = 1
dwhi d_ptr <= 8
itod d_delta, d_ptr
'find adjacent place
d_dot = d_move + d_delta
$cut s_dot, s_board, d_dot, 1
'does adjacent place have a P
$ift s_dot = "P"
'go through the ray of places with a P
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "P": dinc d_loop
endw
$ift s_dot = "C"
d_good = 1
'go back through the ray of places with a P
dwhi d_dot <> d_move
d_dot = d_dot - d_delta
$rep s_board, d_dot, "C"
endw
endi
endi
dinc d_ptr
endw
endi
dift d_good = 1
sg_pass1 = s_board
sub_tea_over_board
endi
dg_pass1 = d_good
sg_pass1 = s_board
ends sub_tea_over_make_cmove
subr sub_tea_over_cevaluate
'updated 2005/11/02
'evaluate the computer position
vari s_any, d_any, s_dot, d_dot
vari d_value, s_board, d_ccount, d_pcount
vari d_50k
d_50k = 50 * 1000
s_board = sg_pass1
sub_tea_over_existing_moves
d_ccount = dg_pass1
d_pcount = dg_pass2
d_value = 0
d_any = 1000 * 1000
dift d_ccount = 0: d_value = d_value - d_any
d_value = d_value + d_pcount - d_ccount
'corners
$cut s_dot, s_board, 111, 1
$cut s_any, s_board, 122, 1
$ift s_dot = "C"
d_value = 1000 * 100 + d_value
$ift s_any = "C": d_value = d_value - d_50k
else
$ift s_any = "C": d_value = d_value - d_50k
endi
$cut s_dot, s_board, 181, 1
$cut s_any, s_board, 172, 1
$ift s_dot = "C"
d_value = 1000 * 100 + d_value
$ift s_any = "C": d_value = d_value + d_50k
else
$ift s_any = "C": d_value = d_value - d_50k
endi
$cut s_dot, s_board, 188, 1
$cut s_any, s_board, 177, 1
$ift s_dot = "C"
d_value = 1000 * 100 + d_value
$ift s_any = "C": d_value = d_value + d_50k
else
$ift s_any = "C": d_value = d_value - d_50k
endi
$cut s_dot, s_board, 118, 1
$cut s_any, s_board, 127, 1
$ift s_dot = "C"
d_value = 1000 * 100 + d_value
$ift s_any = "C": d_value = d_value + d_50k
else
$ift s_any = "C": d_value = d_value - d_50k
endi
'evaluate corners
dg_pass1 = 111
sg_pass1 = s_board
sub_tea_over_corners
d_value = d_value + dg_pass1
dg_pass1 = 118
sg_pass1 = s_board
sub_tea_over_corners
d_value = d_value + dg_pass1
dg_pass1 = 181
sg_pass1 = s_board
sub_tea_over_corners
d_value = d_value + dg_pass1
dg_pass1 = 188
sg_pass1 = s_board
sub_tea_over_corners
d_value = d_value + dg_pass1
dg_pass1 = d_value
ends sub_tea_over_cevaluate
subr sub_tea_over_corners
'evaluate corners for computer moves
'updated 2000/09/20
vari d_any, s_any, d_dot, s_dot
vari d_next, s_next
vari s_board, d_corner, s_corner, d_value
vari d_delta, d_ptr, d_count, d_loop
d_corner = dg_pass1
s_board = sg_pass1
$cut s_corner, s_board, d_corner, 1
'look on either the rank or file
d_ptr = 1
dwhi d_ptr <= 4
itod d_delta, d_ptr
'd_next is next to the corner
d_next = d_corner + d_delta
$cut s_next, s_board, d_next, 1
$ift s_corner = "C"
d_value = d_value + 10000
'do we have a string of C's
d_dot = d_corner
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot = "C"
d_value = d_value + 100
else
dinc d_loop
endi
endw
endi
$ift s_corner = "P"
'go beyond the P's
d_dot = d_corner
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "P": dinc d_loop
endw
$ift s_dot = "C"
'go beyond the C's
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "C": dinc d_loop
endw
$ift s_dot = "-": d_value = d_value - 1000
$ift s_dot = "P": d_value = d_value + 1000
endi
endi
$ift s_corner = "-"
d_next = d_corner + d_delta
$cut s_next, s_board, d_next, 1
$ift s_next = "C"
'go beyond the C's
d_dot = d_next
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "C": dinc d_loop
endw
'remember it will be P's move
$ift s_dot = "P": d_value = d_value - 3000
$ift s_dot = "-"
'do we have a hole
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot = "C": d_value = d_value - 2000
endi
endi
$ift s_next = "P"
'go beyond the P's
d_dot = d_next
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "P": dinc d_loop
endw
$ift s_dot = "C"
'go beyond the C's
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "C": dinc d_loop
endw
$ift s_dot <> "-": d_value = d_value + 4000
endi
endi
endi
dinc d_ptr
endw
'look on the diagonal
d_ptr = 5
dwhi d_ptr <= 8
itod d_delta, d_ptr
'd_next is next to the corner
d_next = d_corner + d_delta
$cut s_next, s_board, d_next, 1
$ift s_corner = "-"
$ift s_next = "C": d_value = d_value - 2500
else
$ift s_next = "C": d_value = d_value + 500
endi
dinc d_ptr
endw
dg_pass1 = d_value
ends sub_tea_over_corners
subr sub_tea_over_existing_moves
'does either side have a move
'updated 2000/09/19
vari s_any, d_any, s_dot, d_dot
vari s_move, d_move, s_alpha, s_numbers, d_good, d_loop
vari s_board, d_delta, d_ptr, d_bad
s_board = sg_pass1
'existing moves
dg_existingmovec = 0
dg_existingmovep = 0
'count
dg_ccount = 0
dg_pcount = 0
d_move = 111
dwhi d_move <= 188
$cut s_dot, s_board, d_move, 1
'counts
$ift s_dot = "C": dinc dg_ccount
$ift s_dot = "P": dinc dg_pcount
$ift s_dot = "-"
d_ptr = 1
dwhi d_ptr <= 8
itod d_delta, d_ptr
'find adjacent place
d_dot = d_move + d_delta
$cut s_dot, s_board, d_dot, 1
'test for possible C move
$ift s_dot = "P"
'go through the ray of places with a P
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "P": dinc d_loop
endw
$ift s_dot = "C": dinc dg_existingmovec
endi
'find adjacent place
d_dot = d_move + d_delta
$cut s_dot, s_board, d_dot, 1
'test for possible P move
$ift s_dot = "C"
'go through the ray of places with a C
d_loop = 1
dwhi d_loop = 1
d_dot = d_dot + d_delta
$cut s_dot, s_board, d_dot, 1
$ift s_dot <> "C": dinc d_loop
endw
$ift s_dot = "P": dinc dg_existingmovep
endi
dinc d_ptr
endw
endi
dinc d_move
endw
ends sub_tea_over_existing_moves
subr sub_address
'updated 2001/08/30
vari d_loop, s_choice
dch$ sg_10, 10, 1
dch$ sg_13, 13, 1
sub_get_filedates
dift dg_pass1 = 1: sub_import
$out " 1. look at addresses"
$out " 2. send addresses to a file"
$inp s_choice, "enter a number"
$ift s_choice = "1"
dg_changes = 0
d_loop = 1
dwhi d_loop = 1
sub_menu_addresses
d_loop = dg_pass1
endw
dift dg_changes > 0: sub_export
endi
$ift s_choice = "2": sub_to_file_with_addresses
ends sub_address
subr sub_to_file_with_addresses
'updated 2006/05/24
'send addresses to file for Judith to use, 14-DEC-1999
vari d_any, s_any, d_dot, s_dot
vari d_record, d_byteinp, s_record, s_line, d_byteout, s_crlf
vari d_count, d_good, d_loop, d_yesbook, d_underdashes, s_dashes
vari s_fileout, s_fileinp, d_length
dch$ s_crlf, 13, 1
dch$ s_any, 10, 1
$app s_crlf, s_any
s_fileinp = "fixaddr.ran"
s_fileout = "address.txt"
fdel d_any, s_fileout
$ch$ s_dashes, "-", 70
$app s_dashes, s_crlf
d_yesbook = 2
d_count = 0
d_underdashes = 2
d_byteinp = 1
d_byteout = 1
d_loop = 1
'output a dash line to begin with
fwri d_length, s_fileout, d_byteout, s_dashes
d_byteout = d_byteout + 72
dwhi d_loop = 1
'read a record
frea s_record, s_fileinp, d_byteinp, 72
d_byteinp = d_byteinp + 72
d_good = 1
$len d_any, s_record
dift d_any <> 72
dinc d_good
dinc d_loop
endi
dift d_good = 1
$cut s_dot, s_record, 71, 1
$ift s_dot <> "W": dinc d_good
endi
dift d_good = 1
'are we entering a new book
$cut s_any, s_record, 1, 7
$ift s_any = "]C BOOK": dinc d_yesbook
'is it an address book
'123456789012345678
']C BOOK: Addresses
$cut s_any, s_record, 1, 15
$ift s_any = "]C BOOK: Addresses": d_yesbook = 1
$cut s_any, s_record, 1, 2
$ift s_any = "]C"
dinc d_good
dinc d_underdashes
endi
dift d_yesbook <> 1: dinc d_good
endi
dift d_good = 1
'do we have a dash line
$cut s_any, s_record, 1, 2
$ift s_any = "]-"
dift d_underdashes <> 1: dinc d_good
d_underdashes = 1
endi
dift d_underdashes <> 1: dinc d_good
endi
dift d_good = 1
'output s_line to file address.txt
$cut s_line, s_record, 1, 70
$cut s_any, s_record, 1, 2
$ift s_any = "]-"
'fix the dash line
s_line = s_dashes
dinc d_count
$out "count = " + d_count
'add a carriage return and a line feed
$app s_line, s_crlf
'write the record to the file
fwri d_length, s_fileout, d_byteout, s_line
d_byteout = d_byteout + 72
endi
$cut s_any, s_record, 1, 2
$ift s_any = ") "
$cut s_any, s_record, 3, 1
$ift s_any <> " "
'take off the beginning )
$rep s_line, 1, " "
'add a carriage return and a line feed
$app s_line, s_crlf
'write the record to the file
fwri d_length, s_fileout, d_byteout, s_line
d_byteout = d_byteout + 72
endi
endi
$cut s_any, s_record, 1, 3
$ift s_any = ") "
s_line = s_dashes
'add a carriage return and a line feed
$app s_line, s_crlf
'output the dash line
fwri d_length, s_fileout, d_byteout, s_line
d_byteout = d_byteout + 72
dinc d_underdashes
dinc d_count
$out "count = " + d_count
endi
endi
endw
ends sub_to_file_with_addresses
subr sub_menu_addresses
'menu of options
vari s_inp
sg_addressran = "FIXADDR.RAN"
$ch$ s_inp, "*", 76
$out s_inp
$out "Program = taddress.tea (c) copyright 1998-2000"
$out "by D La Pierre Ballard."
$out "Version: 11-NOV-1999, taddress.tea was begun on 12-DEC-1998."
$out "Written in the language TeaPro (c) copyright 1997-1998"
$out "by D La Pierre Ballard."
$out s_inp
$out " * to exit"
$out " 1. List addresses"
$inp s_inp, "Enter your choice, address changes=" + dg_changes
$ift s_inp = "1": sub_addresses_list
dg_pass1 = 1
$ift s_inp = "*": dg_pass1 = 2
ends sub_menu_addresses
subr sub_addresses_list
'list all addresses in order for one to be chosen
vari s_any, d_any, s_dot, d_dot, d_more
vari d_count, d_dashprevious, d_length
vari d_record, s_record, d_byte, d_loop, d_good
d_more = 1
d_count = 0
d_dashprevious = 2
d_record = 1
d_loop = 1
dwhi d_loop = 1
'read a record
d_byte = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_byte, 72
d_good = 1
$len d_any, s_record
dift d_any <> 72
dinc d_good
dinc d_loop
endi
dift d_good = 1
$cut s_dot, s_record, 71, 1
$ift s_dot <> "W": dinc d_good
endi
dift d_good = 1
'eliminate two dash lines together
dift d_dashprevious = 1
$cut s_any, s_record, 1, 2
$ift s_any = "]-"
'delete this line
$rep s_record, 71, "d"
fwri d_length, sg_addressran, d_byte, s_record
dinc d_good
endi
endi
endi
dift d_good = 1
dift d_dashprevious = 1
$cut s_any, s_record, 1, 2
$ift s_any <> "]-"
$ift s_any <> "]C"
dift d_count >= 20
sub_show_which
$ift sg_pass1 = "*"
dinc d_loop
dinc d_more
endi
d_count = 0
endi
dinc d_count
'show the record
$cut s_record, s_record, 1, 70
dto$ s_any, d_record, 5, 0
$out s_any + " " + s_record
endi
endi
endi
d_dashprevious = 2
$cut s_any, s_record, 1, 2
$ift s_any = "]-": d_dashprevious = 1
endi
dinc d_record
endw
dift d_more = 1: sub_show_which
ends sub_addresses_list
subr sub_show_which
'get which as a record
vari s_inp, d_loop
s_inp = "Choose a line number or hit return to show more"
$inp s_inp, s_inp + ", * to end"
$isd d_loop, s_inp
dift d_loop = 1: $tod dg_begrec, s_inp
dwhi d_loop = 1
sub_show_address
sub_modify_address
d_loop = dg_pass1
s_inp = "*"
endw
sg_pass1 = s_inp
ends sub_show_which
subr sub_show_address
'show an address on the screen to be modified
vari s_any, d_any, s_dot, d_dot
vari d_record, s_record, d_loop, d_good
dg_endrec = dg_begrec
d_record = dg_begrec
$ch$ s_any, "*", 76
$out s_any
d_loop = 1
dwhi d_loop = 1
d_any = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_any, 72
d_good = 1
$len d_any, s_record
dift d_any <> 72
dinc d_good
dinc d_loop
endi
dift d_good = 1
$cut s_dot, s_record, 71, 1
$ift s_dot <> "W": dinc d_good
endi
dift d_good = 1
$cut s_any, s_record, 1, 2
$ift s_any = "]-"
dinc d_loop
dinc d_good
else
dg_endrec = d_record
$cut s_record, s_record, 1, 70
dto$ s_any, d_record, 5, 0
$out s_any + " " + s_record
endi
endi
dinc d_record
endw
$ch$ s_any, "*", 76
$out s_any
ends sub_show_address
subr sub_modify_address
'do you want to modify the address
vari s_menu, s_inp, d_loop, d_good, s_numbers
vari d_any, s_any, d_dot, s_dot, d_count
vari d_record, s_record, d_byte, s_line, d_update, d_length
s_numbers = "123456789012345678901234567890"
$app s_numbers, s_numbers + "1234567890"
$out "A = Add a line to the above address."
$out "D = Delete a line from the above address."
$out "M = Modify a line from the above address."
$out "N = Add a new address under the above address."
$out "R = Replace a line with a new line in the above address."
$out "T = Take the above address out completely from the file."
s_menu = "Choose an action, * to end, address changes made="
$inp s_menu, s_menu + dg_changes
$cup s_menu, s_menu
$trb s_menu, s_menu
'did we get a line number too
d_record = 0
$len d_any, s_menu
dift d_any > 1
$cut s_any, s_menu, 2, 100
$cut s_menu, s_menu, 1, 1
sg_pass1 = s_any
sub_line_number
d_record = dg_pass1
endi
$ift s_menu = "A"
dift d_record = 0
s_inp = "Enter the line number under which to add a line"
$inp s_inp, s_inp + ", * to end"
sg_pass1 = s_inp
sub_line_number
d_record = dg_pass1
endi
dift d_record > 0
$out "Type in the line to be added, * to end"
$inp s_line, s_numbers
$ift s_line <> "*"
$trr s_line, s_line
$ift s_line = "": s_line = ")"
dinc d_record
'first push to make sure there is room
dg_pass1 = d_record
dg_pass2 = 1
sub_push
'now add the new record
dch$ sg_32, 32, 80
$app s_line, sg_32
$cut s_line, s_line, 1, 70
$app s_line, "W" + sg_10
d_byte = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_byte, s_line
dinc dg_changes
endi
endi
endi
$ift s_menu = "D"
dift d_record = 0
s_inp = "Enter the number of the line you want to delete"
$inp s_inp, s_inp + ", * to end"
sg_pass1 = s_inp
sub_line_number
d_record = dg_pass1
endi
dift d_record > 0
d_byte = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_byte, 70
$app s_record, "d" + sg_10
fwri d_length, sg_addressran, d_byte, s_record
dinc dg_changes
endi
endi
$ift s_menu = "R"
dift d_record = 0
s_inp = "Enter the number of the line you want to replace"
$inp s_inp, s_inp + ", * to end"
sg_pass1 = s_inp
sub_line_number
d_record = dg_pass1
endi
dift d_record > 0
$out "Type in the new replacement line, * to end"
$inp s_line, s_numbers
$ift s_line <> "*"
$trr s_line, s_line
$ift s_line = "": s_line = ")"
'now put in the new record
dch$ sg_32, 32, 80
$app s_line, sg_32
$cut s_line, s_line, 1, 70
$app s_line, "W" + sg_10
d_byte = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_byte, s_line
dinc dg_changes
endi
endi
endi
$ift s_menu = "M"
'read in the line to be modified
d_byte = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_byte, 72
'do we have a good line
d_good = 1
$len d_any, s_record
dift d_any <> 72: dinc d_good
dift d_good = 1
$cut s_any, s_record, 71, 1
$ift s_any <> "W": dinc d_good
dift d_record < dg_begrec: dinc d_good
endi
dift d_good = 1: $cut s_record, s_record, 1, 70
d_update = 0
d_loop = d_good
dwhi d_loop = 1
$out ""
$ch$ s_any, "*", 70
$out s_any
$out "Use ^ to blank characters"
$out "Use ~ to delete characters"
$out "Use | to insert the characters after the |"
$out "Put characters to change to under characters"
$out "Modify line=" + d_record
$out s_numbers
$inp s_line, s_record
$trr s_line, s_line
$ift s_line = "*": s_line = ""
$len d_any, s_line
dift d_any > 0
sg_pass1 = s_record
sg_pass2 = s_line
sub_modify
s_record = sg_pass1
dift dg_pass1 > 0: dinc d_update
else
dinc d_loop
endi
endw
'put record backover
dift d_update > 0
dch$ sg_32, 32, 80
$app s_record, sg_32
$cut s_record, s_record, 1, 70
s_any = s_record + "W" + sg_10
fwri d_length, sg_addressran, d_byte, s_any
dinc dg_changes
endi
endi
$ift s_menu = "N"
'add a new address
d_record = dg_endrec + 1
'push for 10 lines to make room
dg_pass1 = d_record
dg_pass2 = 10
sub_push
'add a dash line
dch$ sg_32, 32, 67
s_record = "]- " + sg_32 + "W "
d_byte = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_byte, s_record
dinc d_record
dg_begrec = d_record
d_count = 0
d_loop = 1
dwhi d_loop = 1
$out "Type in an address line, * to end"
$inp s_inp, s_numbers
$ift s_inp <> "*"
dch$ sg_32, 32, 80
s_record = s_inp + sg_32
$cut s_record, s_record, 1, 70
$app s_record, "W" + sg_10
d_byte = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_byte, s_record
dinc dg_changes
else
dinc d_loop
endi
dift d_count = 10: dinc d_loop
dinc d_record
endw
endi
$ift s_menu = "T"
'take out the current address
d_record = dg_begrec
dwhi d_record <= dg_endrec
d_byte = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_byte, 72
$cut s_any, s_record, 71, 1
$ift s_any = "W"
$rep s_record, 71, "d"
fwri d_length, sg_addressran, d_byte, s_record
dinc dg_changes
'show the deleted record
$cut s_record, s_record, 1, 70
$out s_record
endi
dinc d_record
endw
$out "The address was taken out."
endi
dg_pass1 = 1
$ift s_menu = "*": dinc dg_pass1
ends sub_modify_address
subr sub_line_number
'validate the line number in sg_pass1
vari d_good, d_record, s_any, d_any
s_any = sg_pass1
d_record = 0
$isd d_good, s_any
dift d_good = 1
$tod d_record, s_any
d_any = dg_begrec - 1
dift d_record < d_any: d_record = 0
dift d_record > dg_endrec: d_record = 0
endi
dg_pass1 = d_record
ends sub_line_number
subr sub_modify
'modify line in sg_pass1 using sg_pass2
vari d_any, s_any, d_dot, s_dot, d_update
vari s_linechg, s_linenew, s_numbers
vari d_loop, d_long
s_linenew = sg_pass1
s_linechg = sg_pass2
d_update = 0
'delete characters using a tilde
d_loop = 1
dwhi d_loop = 1
$lok d_dot, s_linechg, 1, "~"
dift d_dot > 0
$del s_linenew, d_dot, 1
$del s_linechg, d_dot, 1
dinc d_update
else
dinc d_loop
endi
endw
'insert characters using a pipe
$lok d_dot, s_linechg, 1, "|"
dift d_dot > 0
d_any = d_dot + 1
$cut s_any, s_linechg, d_any, 100
$trr s_any, s_any
$ins s_linenew, d_dot, s_any
s_linechg = ""
dinc d_update
endi
'replace characters
$trr s_linechg, s_linechg
$len d_long, s_linechg
dift d_long > 0
$trl s_linechg, s_linechg
$len d_any, s_linechg
d_dot = d_long - d_any + 1
$rep s_linenew, d_dot, s_linechg
dinc d_update
endi
'blank ^
d_loop = 1
dwhi d_loop = 1
$lok d_dot, s_linenew, 1, "^"
dift d_dot > 0
$rep s_linenew, d_dot, " "
else
dinc d_loop
endi
endw
sg_pass1 = s_linenew
dg_pass1 = d_update
ends sub_modify
subr sub_push
'push down line number dg_pass1 for dg_pass2 lines
vari d_pushrec, d_many, d_botrec, d_count, d_any, s_delrec
vari d_record, s_record, d_bytetop, d_bytebot, s_byte, d_length
d_pushrec = dg_pass1
d_many = dg_pass2
'd_pushrec must be at least one
dift d_pushrec < 1: d_pushrec = 1
'd_many must be at least one
dift d_many < 1: d_many = 1
'make a deleted record
$ch$ s_delrec, "z", 70
$app s_delrec, "d" + sg_10
'how far down must we go to find d_many deleted lines
d_botrec = d_pushrec
d_count = 0
d_record = d_pushrec
dwhi d_count < d_many
'calculate the bytes and read in the record
d_bytetop = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_bytetop, 72
$len d_any, s_record
'test to see if we read in a record
dift d_any < 72
'since not a record then write a deleted one!
fwri d_length, sg_addressran, d_bytetop, s_delrec
s_record = s_delrec
endi
'do we have a deleted record
$cut s_byte, s_record, 71, 1
$ift s_byte <> "W"
'save the record number of the deleted record
d_botrec = d_record
'increment the count of deleted records
dinc d_count
endi
dinc d_record
endw
'starting with d_botrec read upward and move all
'good lines compacted down
'd_botrec is the last deleted record before d_record
d_record = d_botrec - 1
dwhi d_record >= d_pushrec
'read in d_record and if good put into d_botrec
'calculate the bytes and read in the record
d_bytetop = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_bytetop, 72
'do we have a good record
$cut s_byte, s_record, 71, 1
$ift s_byte = "W"
'calculate the byte position of d_botrec
d_bytebot = d_botrec - 1 * 72 + 1
fwri d_length, sg_addressran, d_bytebot, s_record
ddec d_botrec
'put a deleted record in d_record
d_bytetop = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_bytetop, s_delrec
endi
ddec d_record
endw
ends sub_push
subr sub_import
'updated 2006/05/24
'import file sg_addressexp into FixRan file sg_addressran
vari s_any, d_any
vari d_time1, d_time2, s_date1, s_date2, s_str1, s_str2
vari d_loop, d_num1, d_good, d_dotx
vari d_record, s_record, d_byte, d_long, d_length
d_good = 1
dift d_good = 1
'delete the .ran file
fdel d_any, sg_addressran
d_record = 1
d_byte = 1
d_loop = 1
dwhi d_loop = 1
'tell
d_dotx = d_record % 1000
dift d_dotx = 0: $out "import=" + d_record
'read in 200 bytes at a time
frea s_record, sg_addressexp, d_byte, 200
$len d_long, s_record
'if no bytes read then we are done
dift d_long = 0: dinc d_loop
'if we got a record
dift d_loop = 1
'find first CRLF
s_any = sg_13 + sg_10
$lok d_dotx, s_record, 1, s_any
dift d_dotx = 0: d_dotx = 71
dift d_dotx > 71: d_dotx = 71
dift d_dotx > d_long: d_dotx = d_long + 1
'prepare for the next read
d_byte = d_byte + d_dotx + 1
ddec d_dotx
$cut s_record, s_record, 1, d_dotx
$bes s_record, s_record
'do we have a dash line
$cut s_str1, s_record, 1, 2
$ift s_str1 = "]-"
s_str2 = " - - - - - - - - - - - -"
s_record = s_str1+ s_str2+ s_str2+ s_str2+ s_str2
endi
'prep the record
dch$ sg_32, 32, 80
$app s_record, sg_32
$cut s_record, s_record, 1, 70
$app s_record, "W" + sg_10
d_num1 = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_num1, s_record
dinc d_record
'do we need a deleted record
d_num1 = d_record % 3
dift d_num1 = 0
$ch$ s_record, "z", 71
$app s_record, sg_10
d_num1 = d_record - 1 * 72 + 1
fwri d_length, sg_addressran, d_num1, s_record
dinc d_record
endi
endi
endw
$out sg_addressran + " is built."
endi
ends sub_import
subr sub_export
'updated 2008/02/26, 2006/05/24
'export the file to a .EXP file
vari d_any, s_any, d_dot, s_dot
vari d_record, s_record, d_byteran, s_byte, d_long
vari d_yes1, d_loop, d_num1, s_str1, s_expline
vari s_file1, s_file2, d_length
'export backups file names
s_file1 = "FIXADDR.EX1"
S_file2 = "FIXADDR.EX2"
fdel d_any, s_file2
fren d_any, s_file2, s_file1
fdel d_any, s_file1
fren d_any, s_file1, sg_addressexp
d_record = 1
dg_textbyte = 1
d_loop = 1
dwhi d_loop = 1
'tell
d_num1 = d_record % 1000
dift d_num1 = 0: $out "export=" + d_record
'read a record
d_byteran = d_record - 1 * 72 + 1
frea s_record, sg_addressran, d_byteran, 72
$len d_any, s_record
d_yes1 = 1
'did we read a record
dift d_any <> 72
dinc d_loop
dinc d_yes1
endi
'did we read a good record
dift d_yes1 = 1
$cut s_byte, s_record, 71, 1
$ift s_byte <> "W": dinc d_yes1
endi
'trim the right side and output
dift d_yes1 = 1
$cut s_expline, s_record, 1, 70
$trr s_expline, s_expline
'do we have a ]-
$cut s_str1, s_expline, 1, 2
$ift s_str1 = "]-": s_expline = s_str1
'send to sub_text_file_out
sg_pass1 = sg_addressexp
sg_pass2 = s_expline
sub_text_file_out
endi
dinc d_record
endw
'make small change in .RAN so it will have greater date
frea s_byte, sg_addressran, 1, 72
fwri d_length, sg_addressran, 1, s_byte
ends sub_export
subr sub_get_filedates
'updated 2005/11/02
'determine whether to import or not
vari d_dateexp, d_dateran, s_dot, d_needimport, s_any
sg_addressran = "FIXADDR.RAN"
sg_addressexp = "FIXADDR.EXP"
'build filenames
$ch$ s_dot, "*", 70
$out s_dot
$out "File date for "+sg_addressran+" is "+s_any+" "+d_dateran
$out "File date for "+sg_addressexp+" is "+s_any+" "+d_dateexp
$out s_dot
'is the .EXP file newer
d_needimport = 2
dift d_dateexp > d_dateran: d_needimport = 1
dg_pass1 = d_needimport
ends sub_get_filedates
subr sub_text_file_out
'updated 2005/11/02
'output to text file sg_pass1 the record in sg_pass1
'at byte dg_textbyte
'with CRLF
vari s_line, d_long, d_length
s_line = sg_pass2
$trr s_line, s_line
$app s_line, sg_13 + sg_10
fwri d_length, sg_pass1, dg_textbyte, s_line
$len d_long, s_line
dg_textbyte = dg_textbyte + d_long
ends sub_text_file_out
subr sub_pairing_rounds
'first of pairing subroutines
'pairing of players in a round robin tournament
vari s_any, d_any, s_dot, d_dot
vari d_loop, d_auto, d_sec1, d_sec2
$inp s_any, "Enter number of players"
$isd d_any, s_any
dg_players = 6
dift d_any = 1: $tod dg_players, s_any
'make dg_players an even number
d_any = dg_players % 2
dift d_any = 1: dinc dg_players
dift dg_players > 26: dg_players = 26
$out "There are " + dg_players + " players."
d_auto = 2
$inp s_any, "1 = run continuously, 2 = halt"
$isd d_any, s_any
dift d_any = 1: $tod d_auto, s_any
dg_pairingsshow = 2
$inp s_any, "1 = show pairings during, 2 = show at end"
$isd d_any, s_any
dift d_any = 1: $tod dg_pairingsshow, s_any
'get the beginning time
dsec d_sec1
'prepare the string of players in each round
s_any = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
$cut s_dot, s_any, 1, dg_players
'put the rounds in the pairing string
sg_pairings = ""
d_any = 1
dwhi d_any < dg_players
sg_pairings = sg_pairings + s_dot
dinc d_any
endw
'round 1 = AB,CD,EF
'round 2 = AC,BE,DF
'round 3 = AD,BF,CE
'round 4 = AE,BD,CF
'round 5 = AF,BC,DE
'round 1 = AB,CD
'round 2 = AC,BD
'round 3 = AD,BC
d_loop = 1
dwhi d_loop = 1
sub_pairing_proc
dift d_auto <> 1
$inp s_any, "return for more, * = end"
$ift s_any = "*": dinc d_loop
endi
dift dg_bad2 = 0: dinc d_loop
endw
dg_pairingsshow = 1
sub_pairing_show
'get the ending time
dsec d_sec2
d_sec1 = d_sec2 - d_sec1
$inp s_any, "pairings done in " + d_sec1 + " seconds"
ends sub_pairing_rounds
subr sub_pairing_proc
'process
vari s_any, d_any, s_dot, d_dot
'the pairings for round one will be bytes 1 and 2 in each string
'show what the pairings look like now
dift dg_pairingsshow = 1: sub_pairing_show
'test for a bad pairing
sub_pairing_test
dift dg_bad2 > 0
$cut s_any, sg_pairings, dg_bad2, 2
d_any = dg_bad1 / dg_players + 1
d_any = d_any \ 1
s_any = "bad=" + s_any + " at " + dg_bad1 + " round=" + d_any
d_any = dg_bad2 / dg_players + 1
d_any = d_any \ 1
$app s_any, " and at " + dg_bad2 + " round=" + d_any
dift dg_pairingsshow = 1: $out s_any
sub_pairing_change
endi
ends sub_pairing_proc
subr sub_pairing_change
'change the pairing1 in the round containing dg_bad2
vari s_any, d_any, s_dot, d_dot
vari d_beg, d_end, s_beg, s_end, s_pair, d_loop
vari d_roundbeg
'round 1 = AB,CD,EF,
'round 2 = AC,BE,DF,
'round 3 = AD,BF,CE,
'round 4 = AE,BD,CF,
'round 5 = AF,BC,DE,
d_beg = dg_bad2 % dg_players
d_roundbeg = dg_bad2 - d_beg + 1
$cut sg_round, sg_pairings, d_roundbeg, dg_players
d_loop = 1
dwhi d_loop = 1
dran d_any
d_end = dg_players - 1 * d_any + 2
d_end = d_end \ 1
dift dg_pairingsshow = 1: $out "beg=" + d_beg + ", end=" + d_end
d_any = d_beg % 2
dift d_any = 1
d_any = d_end - d_beg
dift d_any = 1: d_end = d_beg
endi
dift d_end <> d_beg: dinc d_loop
endw
$cut s_beg, sg_round, d_beg, 1
$cut s_end, sg_round, d_end, 1
$rep sg_round, d_beg, s_end
$rep sg_round, d_end, s_beg
'make sure the pairings are in alpha order
sub_pairing_round_alpha
$rep sg_pairings, d_roundbeg, sg_round
'sort by round
$sor sg_pairings, sg_pairings, dg_players
ends sub_pairing_change
subr sub_pairing_test
'test a pairing set to see if legal and where if not
vari s_any, d_any, s_dot, d_dot
vari d_length, s_pair, d_loop1, d_loop2
'round 1 = AB,CD,EF
'round 2 = AC,BE,DF
'round 3 = AD,BF,CE
'round 4 = AE,BD,CF
'round 5 = AF,BC,DE
$len d_length, sg_pairings
dg_bad1 = 1
dg_bad2 = 0
d_loop1 = 1
dwhi d_loop1 = 1
$cut s_pair, sg_pairings, dg_bad1, 2
d_dot = dg_bad1 + 2
dg_bad2 = 0
d_loop2 = 1
dwhi d_loop2 = 1
$lok d_dot, sg_pairings, d_dot, s_pair
d_any = d_dot % 2
dift d_any = 1
dg_bad2 = d_dot
dinc d_loop2
dinc d_loop1
else
dift d_dot = 0
dinc d_loop2
else
d_dot = d_dot + 1
endi
endi
endw
dift dg_bad2 = 0
dg_bad1 = dg_bad1 + 2
dift dg_bad1 > d_length: dinc d_loop1
endi
endw
ends sub_pairing_test
subr sub_pairing_round_alpha
'put pairings in sg_round in alpha order
vari s_any, d_any, s_dot, d_dot
vari s_beg, s_end, d_beg, d_end, d_length
vari d_byte1, d_byte2, s_pair1, s_pair2
$len d_length, sg_round
'turn individual pairings around
d_beg = 1
dwhi d_beg < d_length
$cut s_beg, sg_round, d_beg, 1
d_end = d_beg + 1
$cut s_end, sg_round, d_end, 1
$ift s_beg > s_end
$rep sg_round, d_beg, s_end
$rep sg_round, d_end, s_beg
endi
d_beg = d_beg + 2
endw
$sor sg_round, sg_round, 2
ends sub_pairing_round_alpha
subr sub_pairing_show
'show the pairings as they currently stand
vari s_any, d_any, s_dot, d_dot
vari s_round, d_round, s_pair, d_length, d_count
'round 1 = AB,CD,EF
'round 2 = AC,BE,DF
'round 3 = AD,BF,CE
'round 4 = AE,BD,CF
'round 5 = AF,BC,DE
$out "*******************"
$len d_length, sg_pairings
d_round = 0
s_round = ""
d_count = 0
d_dot = 1
dwhi d_dot < d_length
$cut s_pair, sg_pairings, d_dot, 2
$app s_round, s_pair + ","
d_count = d_count + 2
dift d_count >= dg_players
d_count = 0
dinc d_round
dto$ s_any, d_round, 2, 0
$app s_any, ". "
$out s_any + s_round
s_round = ""
endi
d_dot = d_dot + 2
endw
ends sub_pairing_show
subr sub_prime_speed_test
'updated 2006/03/03, 2005/12/11, 2005/10/08, 2004/02/15, 2004/02/14
'find the first 50,000 primes to test and for speed
vari d_any, s_any, d_dot, s_dot, s_out
vari d_sec1, d_sec2, d_sec3, d_loop, d_count
vari d_todocount, s_dash, d_action
vari d_testprime, d_primetotal, d_lastprime
'd_action=1 for using DFAC
'd_action=2 for not using DFAC
d_action = 2
dift d_action < 99
$ch$ s_dash, "-", 76
$inp s_any, "1=use dfac"
$ift s_any = "*": d_action = 999
$ift s_any = "1": d_action = 1
endi
dift d_action < 99
d_todocount = 100 * 1000
$out "finding the first " + d_todocount + " primes"
endi
dsec d_sec1
d_primetotal = 1 + 2 + 3 + 5 + 7
d_lastprime = 7
'1,2,3,5,7 are presumed
d_count = 5
d_testprime = 11
d_loop = d_action
dwhi d_loop = 1
'find primes with DFAC
dfac d_any, d_testprime
dift d_any = 1
'we have a prime
d_lastprime = d_testprime
d_primetotal = d_primetotal + d_testprime
dinc d_count
dift d_count >= d_todocount: d_loop = 99
endi
d_testprime = d_testprime + 2
endw
dwhi d_loop = 2
'find primes without DFAC
dg_pass1 = d_testprime
sub_prime_test
dift dg_pass2 = 1
'we have a prime
d_lastprime = d_testprime
d_primetotal = d_primetotal + d_testprime
dinc d_count
dift d_count >= d_todocount: d_loop = 99
endi
d_testprime = d_testprime + 2
endw
dsec d_sec2
dift d_action < 99
d_sec3 = d_sec2 - d_sec1
$out s_dash
ded$ s_any, d_primetotal, 0, 0
$out "Prime total = " + s_any
ded$ s_any, d_lastprime, 0, 0
$out "Last prime = " + s_any
ded$ s_any, d_count, 0, 0
$out "Primes count = " + s_any
$out s_dash
endi
dift d_action < 99
$out "The above numbers should be as follows."
$out "Prime total = 62,259,399,013"
$out "Last prime = 1,299,689"
$out "Primes count = 100,000"
$out s_dash
$out "The time was " + d_sec3 + " seconds."
$out s_dash
endi
$inp s_any, "return"
ends sub_prime_speed_test
subr sub_prime_test
'updated 2005/02/14, 2005/02/13
'2005/02/09, 2005/02/06, 2005/01/30, 2004/11/27
'prime test of dg_pass1, return dg_pass2
'dg_pass2=1 means prime
vari d_any, d_dot, s_any, s_dot
vari d_number, d_divisor, d_loop, d_root
d_number = dg_pass1
d_any = 1 / 2
dpow d_root, d_number, d_any
'initialize divisor
d_divisor = 3
'd_loop = 0 for loop
d_loop = 0
dwhi d_loop = 0
'prime testing d_number with d_divisor
'if d_divisor > d_root we have a prime
dift d_divisor > d_root
'd_loop=1 means prime
d_loop = 1
else
'test d_number for factor d_divisor
d_any = d_number / d_divisor \ 1 * d_divisor
'd_number is not prime
dift d_any = d_number: d_loop = d_divisor
endi
'increment divisor
d_divisor = d_divisor + 2
endw
dg_pass2 = d_loop
ends sub_prime_test
subr sub_speedquick
'updated 2008/02/23
vari d_any, d_dot, d_time
dsec d_time
d_dot = 10 ^ 6 * 2
d_any = 0
dwhi d_any < d_dot
dinc d_any
endw
dsec d_any
dg_pass1 = d_any - d_time
ends sub_speedquick