'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