'beginning the teasho.tea program written in Teapro
'which utilizes the OpenTea technology    
'In today's world, we 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 dg_now, sg_now, dg_endprogram
vari sg_build, dg_length, sg_nothing
vari dg_xvalue, dg_yvalue, dg_zvalue, sg_xyzmath

sub_main
endp

subr sub_main
'updated 2003/01/29
'main subroutine

    dg_endprogram = 2
    dwhi dg_endprogram <> 1
	  sub_menu0
    endw
ends sub_main


subr sub_menu0
'updated 2008/02/25
'2007/11/12, 2007/07/17, 2007/03/09, 2006/09/27, 2006/09/25
'2005/10/07, 2005/04/19, 2005/04/18, 2005/02/28, 2004/10/19
'menu of possibilities
    vari d_any, s_any, d_dot, s_dot, s_out
    vari d_inp, d_seconds, s_xvalue, s_aster
    vari s_pick, d_pick    
 
    $trb sg_nothing, " "
    $ch$ s_aster, "*", 70

    $out s_aster
    sg_build = "Program: teasho.tea, build=122, 2008/02/25"
    $out sg_build
    $out "Copyright (c) 1998-2008 D La Pierre Ballard."
    $out "Written in Teapro using the OpenTea technology"
    $out "Copyright (c) 1997-2008 by D La Pierre Ballard."
    $out "This program was begun on 1998/04/03"
    $out "This program may be used by anyone, but there is"
    $out "no warranty of anykind on this program."

    $out s_aster
    s_any = "In today's world, we need computer software"
    $app s_any, " that really works."
    $out s_any

    $out s_aster
    dsec d_seconds
    ded$ s_out, d_seconds, 0, 0
    $out #seconds = # + s_out
    $dat s_out
    $out s_out
    sub_floating_point_test

    $out s_aster
    sub_path_memory_lines
    sub_speedquick
    $out s_aster
    $out "1 = sub_menu_files_and_chars"
    $out "2 = sub_menu_proc_files"
    $out "3 = sub_menu_numbers"
    $out "5 = sub_menu_floating_point"
    $out "6 = sub_menu_programming"
    $out "97 = sub_xyzmath"
    $out "98 = sub_prime_speed_test"
    $out "99 = sub_speed_test " + dg_pass1
    $inp s_pick, "pick a number *=end " + "x=" + dg_xvalue

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    $ift s_pick = "*": dg_endprogram = 1
    dift d_pick = 1: sub_menu_files_and_chars
    dift d_pick = 2: sub_menu_proc_files
    dift d_pick = 3: sub_menu_numbers
    dift d_pick = 5: sub_menu_floating_point
    dift d_pick = 6: sub_menu_programming
    dift d_pick = 97
	  sg_pass1 = "x=x"
	  sub_xyzmath
    endi
    dift d_pick = 98: sub_prime_speed_test
    dift d_pick = 99: sub_speed_test

    sg_pass1 = s_pick
    sub_xyzmath
ends sub_menu0


subr sub_menu_files_and_chars
'updated 2006/08/07
'2006/04/13, 2005/09/21, 2005/07/24, 2005/04/18, 2004/05/11
    vari s_any, d_any, s_dot, d_dot
    vari s_pick, d_pick, s_out, d_inp

    $out "1 = speed"
    $out "2 = watch time change"
    $out "11 = character Set"
    $out "12 = characters in a file"
    $out "13 = readable characters in a file"
    $out "14 = read a file by lines"
    $out "15 = look for duplicate fields between records"
    $out "16 = paste whole file into $inp"
    $out "17 = count particular string in file"
    $out "18 = remove duplicate records from a file"
    $out "24 = read in whole file, lookups, replace"
    $out "25 = save part of a file into a new file"
    $out "28 = zero divide to crash the program"
    $out "30 = copy file to new file using fsip, fapp"
    $out "31 = make file uppercase or lowercase"
    $out "32 = to oldtoe a file"
    $out "41 = hash a string"
    $out "42 = total characters in a file"
    $inp s_pick, "enter number,* = end, x=" + dg_xvalue

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    'Speed
    dift d_pick = 1: sub_speed2

    'watch time change
    dift d_pick = 2: sub_time_watch

    'Characters
    dift d_pick = 11: sub_characters

    'Characters in a file
    dift d_pick = 12: sub_char_in_file

    'Readable characters in a file
    dift d_pick = 13: sub_readable_char_in_file

    'read through a file by lines
    dift d_pick = 14: sub_read_file_by_lines

    'look for duplicate fields between records
    dift d_pick = 15: sub_duplicate_fields

    'count particular string in file
    dift d_pick = 17: sub_count_string_in_file

    'remove duplicate records from a file
    dift d_pick = 18: sub_duplicate_records_remove

    'Read a whole file into memory
    dift d_pick = 24: sub_file_read_lookup_lookat

    'save part of a file into a new file
    dift d_pick = 25: sub_save_part_of_a_file

    'zero divide to crash the program
    dift d_pick = 28: sub_zero_divide

    'copy file to new file using fsip,fapp
    dift d_pick = 30: sub_copy_file_fsip_fapp

    'uppercase or lowercase a file
    dift d_pick = 31: sub_file_to_upper_case

    'to oldtoe a file
    dift d_pick = 32: sub_file_oldtoe

    'hash a string
    dift d_pick = 41: sub_hash

    'total characters in a file
    dift d_pick = 42: sub_file_total_characters

    sg_pass1 = s_pick
    sub_xyzmath
ends sub_menu_files_and_chars


subr sub_menu_proc_files
'updated 2007/03/09, 2007/03/08, 2005/08/31, 2005/04/18, 2004/01/11
    vari s_any, d_any, s_dot, d_dot
    vari s_pick, d_pick, s_out, d_inp, s_xvalue

    $out "1 = count from a number to look for end of exact numbers"
    $out "2 = sub_file_to_fixed_length"
    $out "3 = sub_compare_two_files"
    $out "4 = lookup records of one file in another file"
    $out "41 = random Numbers"
    $out "42 = fibonacci numbers"
    $out "43 = factorial numbers by recursion"
    $out "44 = recursion speed test"
    $out "51 = key numbers"
    $inp s_pick, "enter number,* = end, x=" + dg_xvalue

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    'exact by count
    dift d_pick = 1: sub_exact_by_count

    'make file fixed length
    dift d_pick = 2: sub_file_to_fixed_length

    'compare two files
    dift d_pick = 3: sub_compare_two_files

    'look up records of one file in another file
    dift d_pick = 4: sub_lookup_one_file_in_another_file

    'Random numbers
    dift d_pick = 41: sub_random

    'Fibonacci numbers
    dift d_pick = 42: sub_fibonacci

    'Factorial numbers by recursion
    dift d_pick = 43: sub_factorial

    'subroutine speed test using recursion
    dift d_pick = 44: sub_recursion_speed1

    'Key numbers
    dift d_pick = 51: sub_tag_numbers

    sg_pass1 = s_pick
    sub_xyzmath
ends sub_menu_proc_files


subr sub_menu_numbers
'updated 2005/04/18, 2004/01/01
    vari s_any, d_any, s_dot, d_dot
    vari s_pick, d_pick, s_out, d_inp, s_xvalue

    $out "44 = value of a string"
    $out "45 = sam bass"
    $out "46 = repeating decimals"
    $out "47 = figure interest every way"
    $out "48 = test $tod"
    $out "51 = doubling, powers of two"
    $out "53 = adding 1 to big numbers"
    $out "81 = build a very large string"
    $out "82 = double number math"
    $inp s_pick, "enter number,* = end, x=" + dg_xvalue

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    'value of a string
    dift d_pick = 44: sub_string_value

    'sam bass
    dift d_pick = 45: sub_sam_bass

    'repeating decimals
    dift d_pick = 46: sub_repeating_decimals

    'figure interest every way
    dift d_pick = 47: sub_interest

    'test $tod
    dift d_pick = 48: sub_test_stod

    'Doubles
    dift d_pick = 51: sub_doubling

    dift d_pick = 53: sub_add_one

    'build a large string
    dift d_pick = 81: sub_large_string

    'double number math
    dift d_pick = 82: sub_double_math

    sg_pass1 = s_pick
    sub_xyzmath
ends sub_menu_numbers


subr sub_menu_floating_point
'updated 2003/09/14
    vari s_pick, d_pick, d_any

    $out "1 = floating point cents .01 to .99"
    $out "2 = floating all cents"
    $out "3 = adding and rounding"
    $inp s_pick, "enter a number, * to end"

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    dift d_pick = 1: sub_floating_point_cents

    dift d_pick = 2: sub_floating_all_cents

    'adding floating point numbers
    dift d_pick = 3: sub_adding_rounding
ends sub_menu_floating_point


subr sub_menu_programming
'updated 2008/01/10, 2005/02/28
    vari s_pick, d_pick, d_any

    $out "1 = replace DIFT,$IFT to get rid of past colon command"
    $out "2 = indent Teapro program"
    $inp s_pick, "enter a number, * to end"

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    dift d_pick = 1: sub_teapro_dift_no_past_colon
    dift d_pick = 2: sub_prog_teapro_indent
ends sub_menu_programming


subr sub_count_string_in_file
'updated 2004/05/11
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedata, s_string, d_ctstring

    $inp s_filename, "enter filename"
    $inp s_string, "enter string not in quotes"
    $trb s_string, s_string

    finp s_filedata, s_filename

    $cnt d_ctstring, s_filedata, s_string

    $out "using $cnt"
    s_out = "count of '" + s_string + "' in "
    $app s_out, s_filename + " is=" + d_ctstring
    $inp s_any, s_out
ends sub_count_string_in_file


subr sub_save_part_of_a_file
'updated 2006/09/27
    vari d_any, s_any, d_dot, s_dot
    vari s_filein, s_fileout, d_byte
    vari s_wholefile, s_part, d_long, d_beg
    vari d_loop1, d_loop2
    vari d_process, d_seconds1, d_seconds2, d_good

    d_process = 1
    dift d_process = 1
        $inp s_filein, "enter the name of the input file"
	  $ift s_filein = "*": dinc d_process
    endi
    dift d_process = 1
        flen d_long, s_filein

        dsec d_seconds1
        finp s_wholefile, s_filein
        dsec d_seconds2

        d_any = d_seconds2 - d_seconds1
        $out "seconds to read the file in=" + d_any

        $len d_long, s_wholefile
        ded$ s_any, d_long, 0, 0
        $out "length of the whole file string=" + s_any
    endi

    d_loop1 = d_process
    dwhi d_loop1 = 1
	  d_good = 1
	  dift d_good = 1
		d_beg = 0
		$inp s_any, "enter beginning byte"
		$ift s_any = "*": dinc d_good
		$isd d_any, s_any
		dift d_any = 1: $tod d_beg, s_any		
	  endi
	  dift d_good = 1
		d_long = 0
		$inp s_any, "enter length wanted"
		$ift s_any = "*": dinc d_good
		$isd d_any, s_any
		dift d_any = 1: $tod d_long, s_any		
	  endi
	  dift d_good = 1
		s_fileout = sg_nothing
		$inp s_any, "enter output filename"
		$ift s_any = "*": dinc d_good
		$len d_any, s_any
		dift d_any = 0: dinc d_good
	      s_fileout = s_any		
	  endi
	  dift d_good = 1
		fdel d_any, s_fileout
		$out "beg=" + d_beg + ", long=" + d_long
		$cut s_part, s_wholefile, d_beg, d_long
		fout d_any, s_fileout, s_part
		dbad d_any = 0

		s_any = "file=" + s_fileout + ", length=" + d_long
		$inp s_any, s_any
		$ift s_any = "*": dinc d_good
	  endi

	  d_loop1 = d_good
    endw
ends sub_save_part_of_a_file


subr sub_file_read_lookup_lookat
'updated 2008/02/10, 2006/10/05, 2006/09/27, 2002/07/10
'read a whole file into a string
    vari d_any, s_any, d_dot, s_dot
    vari s_filein, s_fileout, s_record, d_byte
    vari s_wholefile, d_length, d_long
    vari d_loop1, d_loop2, s_find, d_find
    vari d_count, d_line, s_rule
    vari s_pick, d_pick, d_process
    vari d_seconds1, d_seconds2, d_good, s_out, d_plines
    vari s_replace, d_replace, s_asterisks, s_quote

    $ch$ s_asterisks, "*", 76
    dch$ s_quote, 34, 1
    s_wholefile = sg_nothing
    s_rule = "1234567890"
    $app s_rule, s_rule
    $app s_rule, s_rule
    $app s_rule, s_rule

    d_process = 1
    dift d_process = 1
        $inp s_pick, "1 = read records, 2 = read in whole file"
	  $ift s_pick = "*": dinc d_process
        $isd d_any, s_pick
        d_pick = 1
        dift d_any = 1: $tod d_pick, s_pick    
    endi
    dift d_process = 1
        $inp s_filein, "enter the name of the file"
	  $ift s_filein = "*": dinc d_process
    endi
    dift d_process = 1
        flen d_length, s_filein

        dsec d_seconds1
        dift d_pick = 1
            d_byte = 1
            dwhi d_byte <= d_length
	          frea s_record, s_filein, d_byte, 4096
	          $app s_wholefile, s_record

	          d_byte = d_byte + 4096
            endw
        else
	      finp s_wholefile, s_filein
        endi

        dsec d_seconds2
        d_any = d_seconds2 - d_seconds1
        $out "seconds to read the file in=" + d_any

        $len d_length, s_wholefile
        ded$ s_any, d_length, 0, 0
        $out "length of the whole file string=" + s_any
    endi

    d_loop1 = d_process

    dwhi d_loop1 = 1
	  d_good = 1

	  s_any = "enter find string in double quotes or byte number"
	  $inp s_find, s_any
	  $ift s_find = "*"
		dinc d_good
		dinc d_loop1	 
	  endi
	  dift d_good = 1
	      $trb s_find, s_find

		'do we have a d_byte
		$isd d_any, s_find
		dift d_any = 1
		    $tod d_byte, s_find
		    $cut s_record, s_wholefile, d_byte, 80
		    $out s_rule
		    $out s_record

		    dinc d_good
		endi
	  endi
	  dift d_good = 1
	      'do we have a left quote
	      $cut s_any, s_find, 1, 1
	      $ift s_any <> s_quote: dinc d_good
		$off s_any, s_find, 1
	      $ift s_any <> s_quote: dinc d_good
		dift d_good <> 1: $out "bad quotes"
	  endi
	  dift d_good = 1
		'we must begin and end with " = 34 in s_quote
		$par s_find, s_find, s_quote, 2
		$len d_any, s_find
		dift d_any = 0
		    $out "string of zero length"
		    dinc d_good
		endi
	  endi
        dift d_good = 1
		s_any = "if wanted, enter replacement"
		$app s_any, " string in double quotes"
		$inp s_replace, s_any

		'do we have a left quote
		d_replace = 1
		$trb s_replace, s_replace
		$cut s_any, s_replace, 1, 1
		$ift s_any <> s_quote: dinc d_replace

		'do we have a right quote
		$len d_any, s_replace
		$cut s_any, s_replace, d_any, 1
		$ift s_any <> s_quote: dinc d_replace

		dift d_replace = 1
		    $out "before $par=" + s_replace
		    $par s_replace, s_replace, s_quote, 2
		    $out " after $par=" + s_replace
		endi

		$len d_any, s_find
		$out "find=" + s_find + ", length=" + d_any

		$out s_asterisks

		s_out = "finding " + s_quote + s_find + s_quote
		$app s_out, " and beginning byte numbers"
		$app s_out, " in file=" + s_filein
		$out s_out

		dift d_replace = 1
		    s_out = "replacing with " + s_quote + s_replace 
		    $app s_out, s_quote
		    $out s_out

		    dsec d_any
		    $swp s_wholefile, s_find, s_replace
		    dsec d_dot
		    d_any = d_dot - d_any
		    $out "seconds to swap=" + d_any 
		endi

		$out s_asterisks
	  endi
	  dift d_good = 1
		d_count = 0
		d_line = 0
		d_plines = 0
		d_find = 1
		d_loop2 = 1
		dwhi d_loop2 = 1
		    $lok d_find, s_wholefile, d_find, s_find
		    dift d_find = 0
			  dinc d_loop2
		    else
			  dinc d_count
			  dinc d_line

			  'show and print the find below
			  d_any = d_find - 10
			  $cut s_any, s_wholefile, d_any, 60
			  $bes s_any, s_any

			  s_out = d_count + ". byte=" + d_find
			  $app s_out, ": " + s_any
			  $out s_out

		        dift d_line > 15
			      d_line = 0
			      $inp s_any, "more, * to end"
			      $ift s_any = "*": dinc d_loop2
		        endi
			  
			  dinc d_find
		    endi
		endw
	  endi
    endw

    dift d_process = 1
	  d_good = 2
        $inp s_any, "1=output the file"
        $ift s_any = "1": d_good = 1
	  dift d_good = 1
	      $inp s_fileout, "enter the output filename"
		$ift s_fileout = "*": dinc d_good
	  endi
	  dift d_good = 1
		$inp s_any, "1=blank all escapes in the file"
		$ift s_any = "*": dinc d_good
		$ift s_any = "1": $bes s_wholefile, s_wholefile
	  endi
	  dift d_good = 1
	      dsec d_seconds1

	      fout d_any, s_fileout, s_wholefile
 		dbad d_any = 0

            dsec d_seconds2
            d_any = d_seconds2 - d_seconds1
            $out "seconds to output the file=" + d_any
	      $inp s_any, "return"
        endi
    endi
ends sub_file_read_lookup_lookat


subr sub_teapro_dift_no_past_colon
'updated 2006/05/24, 2005/02/28
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_fileinp, s_fileout, s_record, d_filebyte
    vari d_process, d_loop, d_good, d_long, d_count
    vari d_colon, s_line, s_part1, s_part2, s_part3
    vari s_indent, d_indent, d_lines, s_tab

    d_process = 1
    $inp s_fileinp, "enter filename of program to fix"
    $inp s_fileout, "enter filename of fixed program"

    flen d_long, s_fileout
    dift d_long >= 0
	  $out "output file exists=" + s_fileout
	  $inp s_any, "1=delete output file"
	  $ift s_any = "1"
		fdel d_any, s_fileout
	  else
		dinc d_process
	  endi
    endi   

    dch$ s_tab, 9, 1
    d_filebyte = 1
    d_lines = 0
    d_count = 0
    d_loop = d_process
    dwhi d_loop = 1
	  d_good = 1
	  fsip s_record, s_fileinp, d_filebyte
	  dift d_filebyte = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		'replace tab with 6 spaces
		$swp s_record, s_tab, "      "
		'do we have a dift,$ift
		$trb s_line, s_record
		$cut s_any, s_line, 1, 4
		$cup s_any, s_any

		d_dot = 2
		$ift s_any = "DIFT": d_dot = 1
		$ift s_any = "$IFT": d_dot = 1
		d_good = d_dot

		$lok d_colon, s_line, 1, ":"
		dift d_colon = 0: dinc d_good
	  endi
	  dift d_good = 1
		'we have DIFT,$IFT and a colon but is it good
		'break into s_part1,s_part2
		d_any = d_colon - 1
		$cut s_part1, s_line, 1, d_any
		d_any = d_colon + 1
		$cut s_part2, s_line, d_any, 9999

		'we have to have even counts of " and # in each
		$cnt d_any, s_part1, #"#
		d_any = d_any % 2
		dift d_any <> 0: dinc d_good

		$cnt d_any, s_part2, #"#
		d_any = d_any % 2
		dift d_any <> 0: dinc d_good

		$cnt d_any, s_part1, "#"
		d_any = d_any % 2
		dift d_any <> 0: dinc d_good

		$cnt d_any, s_part2, "#"
		d_any = d_any % 2
		dift d_any <> 0: dinc d_good
	  endi    
	  dift d_good = 1
		'we have one
		$trb s_part1, s_part1
		$trb s_part2, s_part2

		'get d_indent
		$trr s_line, s_record
		$len d_dot, s_line
		$trl s_line, s_line
		$len d_any, s_line
		d_indent = d_dot - d_any
		$ch$ s_indent, " ", d_indent

		'prep the parts
		s_part1 = s_indent + s_part1
		s_part2 = "    " + s_indent + s_part2
		s_part3 = s_indent + "endi"

		'output the lines
		dinc d_count
		$out s_record

		fapp d_any, s_fileout, s_part1
		dbad d_any = 0

		fapp d_any, s_fileout, s_part2
		dbad d_any = 0

		fapp d_any, s_fileout, s_part3
		dbad d_any = 0

		d_lines = d_lines + 3
	  else
		'output the uninteresting line
		fapp d_any, s_fileout, s_record
		dbad d_any = 0
		dinc d_lines
	  endi
    endw
    $inp s_any, "done count=" + d_count + ", lines=" + d_lines
ends sub_teapro_dift_no_past_colon


subr sub_floating_point_cents
'updated 2003/09/14
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_money, d_loop, d_count

    d_money = 0

    $inp s_any, "enter whole dollars to begin"
    $isd d_any, s_any
    dift d_any = 1: $tod d_money, s_any

    d_money = d_money * 100
    d_count = 0
    d_loop = 1
    dwhi d_loop = 1
	  d_any = d_money / 100
	  $out d_any

	  dinc d_count
	  d_any = d_count % 20
	  dift d_any = 0: $inp s_any, "more"

	  dinc d_money
	  dift d_count > 99: dinc d_loop
    endw
    $inp s_any, "done"
ends sub_floating_point_cents


subr sub_floating_all_cents
'updated 2003/09/14
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_total, d_roundtot, d_loop, d_count, d_maxcount
    vari d_cents, d_dollars

    d_maxcount = 1000
    $inp s_any, "how many times each"
    $isd d_any, s_any
    dift d_any = 1: $tod d_maxcount, s_any

    d_total = 0
    d_roundtot = 0
    d_count = 0
    d_cents = 1
    d_dollars = d_cents / 100
    d_loop = 1
    dwhi d_loop = 1
	  d_total = d_total + d_dollars

	  d_roundtot = d_roundtot + d_dollars
	  d_roundtot = d_roundtot * 100
	  drou d_roundtot, d_roundtot
	  d_roundtot = d_roundtot / 100

	  dinc d_count
	  dift d_count >= d_maxcount
		s_out = "count=" + d_count
		$app s_out, ", total=" + d_total
		$app s_out, ", roundtot=" + d_roundtot
		$app s_out, ", cents=" + d_cents
		$out s_out

		d_count = 0
		d_total = 0
		d_roundtot = 0

		dinc d_cents
		dift d_cents >= 100: dinc d_loop

		d_dollars = d_cents / 100
		d_any = d_cents % 20
		dift d_any = 0: $inp s_any, "more"
	  endi
    endw
    $inp s_any, "done"
ends sub_floating_all_cents


subr sub_duplicate_records_remove 
'updated 2006/08/07, 2002/02/19
    vari s_any, d_any, s_dot, d_dot
    vari s_oldrecord, s_newrecord
    vari s_oldestrecord, s_newfield, d_totcount, d_seecount
    vari d_loop, d_good, d_process, d_showskipped
    vari s_inpfilename, s_outfilename, d_filebyte
    vari d_ctall, d_ctgood, d_ctskipped

    d_process = 1
    dift d_process = 1
        $inp s_inpfilename, "enter input filename"
	  $ift s_inpfilename = "*": dinc d_process
    endi
    dift d_process = 1
        $inp s_outfilename, "enter output filename"
	  $ift s_outfilename = "*": dinc d_process
    endi
    dift d_process = 1
	  flen d_any, s_outfilename
	  dift d_any >= 0
		$inp s_any, "1=purge file=" + s_outfilename
		$ift s_any = "*": dinc d_process
		$ift s_any = "1"
		    fdel d_any, s_outfilename
		    dift d_any <> 1
			  $out "cannot delete"
			  dinc d_process
		    endi
		endi
	  endi
    endi
    dift d_process = 1
	  d_showskipped = 2
	  $inp s_any, "1=show duplicates"
	  $ift s_any = "*": dinc d_process
	  $ift s_any = "1": d_showskipped = 1
    endi

    d_ctall = 0
    d_ctgood = 0
    d_ctskipped = 0
    d_good = 2
    d_filebyte = 1

    d_loop = d_process
    dwhi d_loop = 1
	  dinc d_ctall
	  d_any = d_ctall % 100
	  dift d_any = 0: $sho "record=" + d_ctall

	  s_oldrecord = s_newrecord

	  'sip in a record starting at d_filebyte
	  fsip s_newrecord, s_inpfilename, d_filebyte

	  dift d_filebyte > 0
		$ift s_newrecord <> s_oldrecord
		    dift d_ctall > 1
			  'output old if diff and new not the first
		        dinc d_ctgood
		        fapp d_any, s_outfilename, s_oldrecord
			  dbad d_any < 2
		    endi
		else
		    dift d_showskipped = 1
		        $out d_ctall + " " + s_oldrecord
		        $out d_ctall + " " + s_newrecord
		    endi

		    dinc d_ctskipped
		endi
	  else
	      dinc d_ctgood
            fapp d_any, s_outfilename, s_oldrecord
		dbad d_any < 2

		dinc d_loop
	  endi
    endw

    s_any = "total=" + d_ctall + ", good=" + d_ctgood
    $app s_any, ", skipped=" + d_ctskipped
    $inp s_any, s_any
ends sub_duplicate_records_remove


subr sub_duplicate_fields 
'updated 2002/02/19
    vari s_any, d_any, s_dot, d_dot
    vari s_oldrecord, s_newrecord, s_filename, d_filebyte
    vari s_oldfield, s_newfield, d_totcount, d_seecount
    vari d_begin, d_length, d_loop, d_good

    d_good = 1
    $inp s_filename, "enter file name"

    $inp s_any, "enter field beginning position"
    $isd d_any, s_any
    dift d_any <> 1
	  dinc d_good
	  $out "bad beginning position"
    else
	  $tod d_begin, s_any
    endi

    $inp s_any, "enter field length"
    dift d_any <> 1
	  dinc d_good
	  $out "bad field length"
    else
	  $tod d_length, s_any
    endi

    d_seecount = 0
    d_totcount = 0
    s_newfield = sg_nothing
    d_filebyte = 1
    d_loop = d_good
    dwhi d_loop = 1
	  d_any = d_totcount % 1000
	  dift d_any = 0: $sho "record=" + d_totcount

	  s_oldfield = s_newfield

	  fsip s_newrecord, s_filename, d_filebyte
	  dift d_filebyte > 0
		dinc d_totcount
		$cut s_newfield, s_newrecord, d_begin, d_length

		$ift s_newfield = s_oldfield
		    $out s_newrecord
		    dinc d_seecount
		endi
	  else
		dinc d_loop
	  endi
    endw

    $inp s_any, "total count=" + d_totcount + ", same=" + d_seecount
ends sub_duplicate_fields

subr sub_interest
'updated 2005/09/05, 2001/11/27
'interest in every way
    vari s_any, d_any, s_dot, d_dot
    vari d_loop, d_good, d_process, s_out, s_inp
    vari s_dashes, d_yescount, d_mult, d_periodrate
 
    vari d_begmoney, d_yearrate, d_periodsper
    vari d_periodcount, d_payment, d_endmoney
    vari d_which

    vari d_holdbegmoney, d_holdyearrate, d_holdperiodsper
    vari d_holdperiodcount, d_holdpayment, d_holdendmoney
    vari d_holdwhich

    $ch$ s_dashes, "-", 76
    d_holdbegmoney = 0
    d_holdyearrate = 75 / 1000
    d_holdperiodsper = 12
    d_holdperiodcount = 60
    d_holdpayment = 0
    d_holdendmoney = 0
    d_holdwhich = 6

    d_begmoney = 0
    d_yearrate = 75 / 1000
    d_periodsper = 12
    d_periodcount = 60
    d_payment = 0
    d_endmoney = 0
    d_which = 6

    d_loop=1
    dwhi d_loop=1
	  $out s_dashes
	  $out "if beginning money < 0 then we have a loan"
	  $out "1. beginning money =  " + d_begmoney
	  $out "2. year rate =        " + d_yearrate
	  $out "3. periods per year = " + d_periodsper
	  $out "4. period count =     " + d_periodcount
	  $out "5. payment amount =   " + d_payment
	  $out "6. ending money =     " + d_endmoney
	  $out "find=" + d_which
	  $out s_dashes

	  d_process = 1
	  dift d_process = 1
		d_begmoney = d_holdbegmoney
		d_yearrate = d_holdyearrate
		d_periodsper = d_holdperiodsper
		d_periodcount = d_holdperiodcount
		d_payment = d_holdpayment
		d_endmoney = d_holdendmoney
		d_which = d_holdwhich
	  endi
	  dift d_process = 1
	      $inp s_inp, "enter which to find = " + d_which
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_which, s_inp
	  endi
	  dift d_process = 1
		$out "make beginning money < 0 for payments to a loan"
	      $inp s_inp, "enter beginning money = " + d_begmoney
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_begmoney, s_inp
	  endi
	  dift d_process = 1
	      $inp s_inp, "enter year rate = " + d_yearrate
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_yearrate, s_inp
	  endi
	  dift d_process = 1
	      $inp s_inp, "enter periods per year = " + d_periodsper
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_periodsper, s_inp
	  endi
	  dift d_process = 1
	      $inp s_inp, "enter period count = " + d_periodcount
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_periodcount, s_inp
	  endi
	  dift d_process = 1
	      $inp s_inp, "enter payment amount = " + d_payment
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_payment, s_inp
	  endi
	  dift d_process = 1
	      $inp s_inp, "enter ending money = " + d_endmoney
	      $ift s_inp = "*": dinc d_process
		$isd d_any, s_inp
		dift d_any = 1: $tod d_endmoney, s_inp
	  endi
        d_loop = d_process
	  dift d_process = 1
		d_holdbegmoney = d_begmoney
		d_holdyearrate = d_yearrate
		d_holdperiodsper = d_periodsper
		d_holdperiodcount = d_periodcount
		d_holdpayment = d_payment
		d_holdendmoney = d_endmoney
		d_holdwhich = d_which
	  endi
	  dift d_process = 1
		'find d_endmoney
		d_yescount = 0
		dift d_begmoney > 0: dinc d_yescount
		dift d_yearrate > 0: dinc d_yescount
		dift d_periodsper > 0: dinc d_yescount
		dift d_periodcount > 0: dinc d_yescount
		dift d_payment = 0: dinc d_yescount
		dift d_endmoney = 0: dinc d_yescount
		dift d_which = 6: dinc d_yescount

		dift d_yescount = 7
		    'get d_periodrate
		    d_periodrate = d_yearrate / d_periodsper

		    'get the multiplier
		    d_any = d_periodrate + 1
		    dpow d_mult, d_any, d_periodcount

		    d_endmoney = d_begmoney * d_mult
		    dinc d_process
		endi
	  endi
	  dift d_process = 1
		'find d_begmoney
		d_yescount = 0
		dift d_begmoney = 0: dinc d_yescount
		dift d_yearrate > 0: dinc d_yescount
		dift d_periodsper > 0: dinc d_yescount
		dift d_periodcount > 0: dinc d_yescount
		dift d_payment = 0: dinc d_yescount
		dift d_endmoney > 0: dinc d_yescount
		dift d_which = 1: dinc d_yescount

		dift d_yescount = 7
		    'get d_periodrate
		    d_periodrate = d_yearrate / d_periodsper

		    'get the multiplier
		    d_any = d_periodrate + 1
		    dpow d_mult, d_any, d_periodcount

		    d_begmoney = d_endmoney / d_mult
		    dinc d_process
		endi
	  endi
	  dift d_process = 1
		'find d_payment with d_begmoney = 0
		d_yescount = 0
		dift d_begmoney = 0: dinc d_yescount
		dift d_yearrate > 0: dinc d_yescount
		dift d_periodsper > 0: dinc d_yescount
		dift d_periodcount > 0: dinc d_yescount
		dift d_payment = 0: dinc d_yescount
		dift d_endmoney > 0: dinc d_yescount
		dift d_which = 5: dinc d_yescount

		dift d_yescount = 7
		    'get d_periodrate
		    d_periodrate = d_yearrate / d_periodsper

		    'get the multiplier
		    d_any = d_periodrate + 1
		    dpow d_mult, d_any, d_periodcount
		    ddec d_mult

		    d_payment = d_endmoney * d_periodrate / d_mult
		    dinc d_process
		endi
	  endi
	  dift d_process = 1
		'find d_payment with negative d_begmoney = loan
		d_yescount = 0
		dift d_begmoney < 0: dinc d_yescount
		dift d_yearrate > 0: dinc d_yescount
		dift d_periodsper > 0: dinc d_yescount
		dift d_periodcount > 0: dinc d_yescount
		dift d_payment = 0: dinc d_yescount
		dift d_endmoney = 0: dinc d_yescount
		dift d_which = 5: dinc d_yescount

		dift d_yescount = 7
		    'get d_periodrate
		    d_periodrate = d_yearrate / d_periodsper

		    'get the multiplier
		    d_any = d_periodrate + 1
		    dpow d_mult, d_any, d_periodcount

		    d_any = d_mult - 1
		    d_dot = - d_begmoney
		    d_payment = d_dot * d_periodrate * d_mult / d_any
		    dinc d_process
		endi
	  endi
    endw
ends sub_interest


subr sub_read_file_by_lines
'updated 2001/11/27
    vari s_any, d_any, s_dot, d_dot
    vari s_filename, d_filebyte, s_record
    vari d_loop1, d_loop2, d_process, d_linecount
    vari d_good, s_input, s_dashes

    $ch$ s_dashes, "-", 76

    d_process = 1
    $inp s_filename, "enter the filename, * to end"
    $ift s_filename = "*": dinc d_process

    $out s_dashes
    d_linecount = 0
    d_filebyte = 1
    d_loop1 = d_process

    dwhi d_loop1 = 1
	  d_good = 1

	  fsip s_record, s_filename, d_filebyte
	  $len d_any, s_record
	  dift d_any = 0: dinc d_good

	  dift d_good = 1
		d_loop2 = 1
		dwhi d_loop2 = 1
		    $cut s_dot, s_record, 1, 70
		    $cut s_record, s_record, 71, 99999

		    dinc d_linecount
		    dift d_linecount > 20
			  $inp s_any, "more to this line"
		    endi

		    $out s_dot

		    $len d_any, s_record
		    dift d_any = 0: dinc d_loop2
		endw
	  endi
	  dift d_linecount >= 20
		$out s_dashes
		d_linecount = 0

		$out "filename=" + s_filename + ", byte=" + d_filebyte
		$inp s_input, "return or enter line number, * to end"

		$isd d_any, s_input
		dift d_any = 1: $tod d_filebyte, s_input
		$ift s_input = "*": dinc d_loop1

		$out s_dashes
	  endi
	  dift d_filebyte = 0: dinc d_loop1
    endw
    $inp s_any, "end of file"
ends sub_read_file_by_lines


subr sub_repeating_decimals
'updated 2002/05/10
'prime numbers whose reciprocals repeat every five
'A person had this on a special math test on 29-OCT-2001
'A person missed this one but made the highest 
'score in the school
    vari d_any, s_any, d_dot, s_dot
    vari s_number, d_number, d_loop, s_five1, s_five2
    vari d_show, s_out

    d_show = 2
    $inp s_any, "1=show only answers"
    $ift s_any = "1": d_show = 1

    d_number = 1
    d_loop = 1
    dwhi d_loop = 1
	  dift d_show <> 1: $out d_number
	  d_any = 1 / d_number
	  dto$ s_number, d_any, 0, 0
	  $lok d_dot, s_number, 1, "."

	  dift d_dot > 0
		dinc d_dot
		$cut s_five1, s_number, d_dot, 5

		d_dot = d_dot + 5
		$cut s_five2, s_number, d_dot, 5

		$ift s_five1 = s_five2
		    s_out = "number=" + d_number + ", reciprocal=" + s_number

		    dfac d_any, d_number
		    dift d_any = 1: $app s_out, " prime"
		    $out s_out
		    dift d_show <> 1: $inp s_any, "return"
		endi
	  endi

	  dinc d_number	  
	  dpow d_any, 10, 5
	  dift d_number > d_any: dinc d_loop
    endw
    $inp s_any, "done"
ends sub_repeating_decimals


subr sub_file_to_fixed_length
'updated 2001/10/06
    vari d_any, s_any, d_dot, s_dot
    vari s_file1, s_record, d_filebyte
    vari s_file2, s_blanks, d_long, d_tell
    vari d_loop, s_endchar, d_length

    $inp s_file1, "name of file1"
    $inp s_file2, "name of file2"

    d_length = 80
    $inp s_any, "length to make records, counting to ending byte"
    $isd d_any, s_any
    dift d_any = 1: $tod d_length, s_any

    $inp s_endchar, "character to put in last byte end of records"

    d_long = d_length - 1
    $ch$ s_blanks, " ", 1000
    d_tell = 0
    d_filebyte = 1
    d_loop = 1

    dwhi d_loop = 1
	  dinc d_tell
	  d_any = d_tell % 100
	  dift d_any = 0: $sho "record=" + d_tell

	  fsip s_record, s_file1, d_filebyte
	  dift d_filebyte > 0
		$app s_record, s_blanks
		$cut s_record, s_record, 1, d_long
		$app s_record, s_endchar
		fapp d_any, s_file2, s_record
	  else
		dinc d_loop
	  endi
    endw
    $inp s_any, "done"
ends sub_file_to_fixed_length


subr sub_zero_divide
'updated 2000/12/15
    vari d_any, s_any, d_dot, s_dot

    d_dot = 0
    d_any = 1944 / d_dot
ends sub_zero_divide


subr sub_floating_point_test
'updated 2005/04/19, 2004/09/25
    vari d_any, s_any, d_dot, s_dot, s_out
   
    dpow d_any, 10, 15
    d_any = d_any / 3
    ded$ s_out, d_any, 0, 0

    s_out = "10E15/3=" + s_out

    s_any = "error: floating point: "
    $lok d_dot, s_out, 1, "."

    dift d_dot > 0
	  ddec d_dot
	  $cut s_dot, s_out, d_dot, 3
	  $ift s_dot = "3.3": s_any = "ok: floating point: "
    endi
    $out s_any + s_out
ends sub_floating_point_test



subr sub_exact_by_count
'updated 2005/09/05, 2000/12/15
    vari d_any, s_any, d_dot, s_dot
    vari d_number, d_loop, d_count, d_many

    $inp s_any, "Enter the beginning number to count from"
    $tod d_number, s_any

    $tod d_many, "999999"
    d_count = 0
    d_loop = 1

    dwhi d_loop = 1
	  dift d_count > d_many
		d_count = 0
	      ded$ s_any, d_number, 20, 20
		$out "Exact by count = " + s_any
	  endi
	  dinc d_count
	  dinc d_number
    endw
ends sub_exact_by_count


subr sub_char_in_file
'updated 2005/11/30, 2005/04/19, 2005/02/10, 2001/12/28
'show characters in a file
    vari d_any, s_any, d_dot, s_dot, s_out
    vari s_record, d_byte, s_file, d_loop, d_char, s_char
    vari d_length, d_long, s_show, d_lenfile
    vari d_column, d_prevchar, s_dashes

    $inp s_file, "enter the filename"
    $cup s_file, s_file
    flen d_lenfile, s_file

    $ch$ s_dashes, "-", 76
    d_prevchar = 0
    d_length = 20
    d_column = 0
    d_byte = 1
    d_loop = 1

    dwhi d_loop = 1
	  frea s_record, s_file, d_byte, d_length
	  $len d_long, s_record

	  dift d_long > 0
		s_show = sg_nothing
		d_dot = 1

		dwhi d_dot <= d_long
		    d_prevchar = d_char
		    $cut s_char, s_record, d_dot, 1
		    $chd d_char, s_char

		    dinc d_column
		    dift d_char < 32
			  s_char = "esc"
			  d_column = 0
		    endi			  
		    dift d_char > 126
			  s_char = "esc"
			  d_column = 0
		    endi			  

		    's_show will show the non escapes at the bottom
		    $ift s_char <> "esc": $app s_show, s_char

		    d_any = d_byte + d_dot - 1

		    dto$ s_any, d_any, 9, 0
		    s_out = "file byte=" + s_any 

		    dto$ s_any, d_column, 5, 0
		    $app s_out, "  column =" + s_any 

		    $app s_out, "  char = " + "'" + s_char + "'" 		     

		    dto$ s_any, d_char, 3, 0
		    $app s_out, "  " + s_any 

		    $out s_out

		    dift d_char = 10: $out s_dashes

		    dinc d_dot
		endw	   
		$out s_show
	  else
		dinc d_loop
	  endi

	  s_out = "* to end, or enter byte number, file=" + s_file
	  $app s_out, ", length=" + d_lenfile
	  $inp s_any, s_out
	  $ift s_any = "*": dinc d_loop

	  $isd d_any, s_any
	  dift d_any = 1
		$tod d_byte, s_any
		d_column = 0
	  else
	      d_byte = d_byte + d_length
	  endi
    endw
ends sub_char_in_file


subr sub_readable_char_in_file
'updated 2002/11/17
'show characters in a file
    vari d_any, s_any, d_dot, s_dot
    vari s_record, d_byte, s_file, d_loop, d_char, s_char
    vari d_length, d_long, s_show, d_count, d_line, s_1310

    $inp s_file, "enter the filename"

    dch$ s_any, 13, 1
    dch$ s_dot, 10, 1
    s_1310 = s_any + s_dot

    d_line = 0
    d_count = 0
    s_show = sg_nothing
    d_length = 20
    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1
	  frea s_record, s_file, d_byte, d_length
	  $len d_long, s_record
	  dift d_long > 0
		d_dot = 1
		dwhi d_dot <= d_long
		    $cut s_char, s_record, d_dot, 1
		    $chd d_char, s_char

		    dift d_char > 32
		        dift d_char <= 126
				$app s_show, s_char
				dinc d_count
				dift d_count >= 70
				    $out s_show
				    s_show = sg_nothing
				    d_count = 0
				    dinc d_line
				endi
			  endi
		    endi
		    dinc d_dot
		endw	   
	  else
		dinc d_loop
	  endi

	  dift d_line >= 5 
		$out s_show
		s_show = sg_nothing
		d_line = 0

	      $inp s_any, d_byte + ", more, * to end"
		$ift s_any = "*": dinc d_loop
	  endi
        d_byte = d_byte + d_long
    endw
    $inp s_any, "end"
ends sub_readable_char_in_file


subr sub_copy_file_fsip_fapp
'updated 2001/08/28
'copy file using fsip,fapp
    vari d_any, s_any, d_dot, s_dot
    vari s_file1, s_file2, d_byte, s_line

    $inp s_file1, "enter name of file to copy from"
    $inp s_file2, "enter name of file to copy to"

    d_byte = 1
    dwhi d_byte > 0
	  fsip s_line, s_file1, d_byte
	  dift d_byte > 0
	      $out s_line
	      $out "byte=" + d_byte

	      fapp d_any, s_file2, s_line
	  endi
    endw
    $inp s_any, "done"
ends sub_copy_file_fsip_fapp


subr sub_file_to_upper_case
'updated 2006/04/13
'uppercase or lowercase a file
    vari d_any, s_any, d_dot, s_dot
    vari s_file1, s_file2, d_byte, s_line, d_upper, d_process

    d_process = 1
    dift d_process = 1
        $inp s_file1, "enter name of file to copy from"
        $ift s_file1 = "*": dinc d_process
    endi
    dift d_process = 1
        $inp s_file2, "enter name of file to copy to"
        $ift s_file2 = "*": dinc d_process
    endi
    dift d_process = 1
        $inp s_any, "1=uppercase, 2=lowercase"
        $ift s_any = "*": dinc d_process
        d_upper = 1
        $ift s_any <> "1": dinc d_upper
    endi
    dift d_process = 1
        finp s_line, s_file1
        $cup s_line, s_line
        fout d_any, s_file2, s_line
	  dbad d_any = 0
        $inp s_any, "done"
    endi
ends sub_file_to_upper_case


subr sub_file_oldtoe
'updated 2006/04/08, 2006/03/17, 2006/03/16
'oldtoe 
    vari d_any, s_any, d_dot, s_dot, s_out
    vari d_long, d_loop, d_byte, s_line1, s_line2, d_seconds
    vari s_char, d_char, s_file1, s_file2, d_process
    vari s_key, d_which

    d_process = 1
    dift d_process = 1
	  $inp s_file1, "enter input file name"
	  $ift s_file1 = "*": dinc d_process
    endi
    dift d_process = 1
	  $inp s_file2, "enter output file name"
	  $ift s_file2 = "*": dinc d_process
    endi
    dift d_process = 1
	  $inp s_key, "enter key word"
	  $ift s_key = "*": dinc d_process
    endi
    dift d_process = 1
	  d_which = 1
	  $inp s_any, "1=code, 2=decode"
	  $ift s_any = "*": dinc d_process
	  $ift s_any = "2": d_which = 2
    endi
    dift d_process = 1
        dsec d_seconds

        finp s_line1, s_file1
        $len d_long, s_line1

        fdel d_any, s_file2

        $toe s_line2, s_line1, s_key, d_which

        fout d_any, s_file2, s_line2
        dbad d_any = 0

        dsec d_any
        d_seconds = d_any - d_seconds
        $inp s_any, "done, length=" + d_long + ", sec=" + d_seconds
    endi
ends sub_file_oldtoe


subr sub_factorial
'updated 2000/12/15
'find factorial numbers by recursion
    vari d_any, s_any, d_dot, s_dot
    vari d_number, d_factorial

    $inp s_any, "enter number to find factorial of"
    $isd d_any, s_any
    dift d_any = 1
	  $tod d_number, s_any
	  dg_pass1 = d_number
	  sub_findfactorial
	  d_factorial = dg_pass1
	  $inp s_any,"The factorial of " + d_number + " is " + d_factorial
    endi
ends sub_factorial


subr sub_findfactorial
'updated 2000/12/15
    vari d_any, s_any, d_dot, s_dot
    vari d_factorial, d_number

    d_number = dg_pass1
    dift d_number > 1
	  d_any = d_number - 1

	  dg_pass1 = d_any
	  sub_findfactorial
	  d_any = dg_pass1

	  d_factorial = d_number * d_any
    else
	  d_factorial = 1
	  $inp s_any, "at bottom"
    endi
    $out d_factorial
    dg_pass1 = d_factorial
ends sub_findfactorial


subr sub_recursion_speed1
'updated 2000/12/15
'test speed of calling a subroutine using recursion
    vari d_any, s_any, d_dot, s_dot
    vari d_time, d_count, d_howmany

    dg_pass2 = 200
    $inp s_any, "How deep the recursion, default = 200"
    $isd d_any, s_any
    dift d_any = 1: $tod dg_pass2, s_any

    d_howmany = 1
    $inp s_any, "How many times to call the recursion?"
    $isd d_any, s_any
    dift d_any = 1: $tod d_howmany, s_any

    dg_pass3 = 2
    $inp s_any, "1 = stop at bottom"
    $ift s_any = "1": dg_pass3 = 1

    dg_pass4 = 2
    $inp s_any, "1 = show count going into"
    $ift s_any = "1": dg_pass4 = 1

    dsec d_time
    d_count = 0
    dwhi d_count < d_howmany
	  dg_pass1 = 0
	  sub_recursion_speed2
	  d_dot = dg_pass1

	  dinc d_count
    endw
    dsec d_any

    d_time = d_any - d_time
    $out "Time = " + d_time
    $out "total=" + d_dot

    $inp s_any, "return"    
ends sub_recursion_speed1


subr sub_recursion_speed2
'updated 2000/12/15
'test speed of calling a subroutine using recursion
    vari d_any, s_any

    d_any = dg_pass1
    dinc d_any
    s_any = "recursion=" + d_any + " to " + dg_pass2

    dift dg_pass4 = 1: $out d_any

    dift d_any < dg_pass2
	  dg_pass1 = d_any
	  sub_recursion_speed2
	  d_any = dg_pass1  
    else
	  dift dg_pass3 = 1
		'stop at the bottom
		$inp s_any, "bottom at " + d_any
	  endi
    endi

    dg_pass1 = d_any
ends sub_recursion_speed2


subr sub_string_value
'updated 2000/12/15
    vari d_any, s_any, d_dot, s_dot, d_pat, s_pat
    vari s_string, d_value, d_long

    $inp s_string, "enter the string to find the value of"
    $trb s_string, s_string
    $cup s_string, s_string

    $len d_long, s_string
    d_dot = 1
    dwhi d_dot <= d_long
	  $cut s_dot, s_string, d_dot, 1

	  $ift s_dot < "A"
		$del s_string, d_dot, 1
		ddec d_long
		ddec d_dot
	  else
	      $ift s_dot > "Z"
		    $del s_string, d_dot, 1
		    ddec d_long
		    ddec d_dot
		endi
	  endi

	  dinc d_dot
    endw

    $cut s_string, s_string, 1, 10
    $len d_long, s_string

    d_value = 0
    d_dot = 1
    dwhi d_dot <= d_long
	  $cut s_dot, s_string, d_dot, 1
	  $chd d_any, s_dot
	  d_value = d_any * d_any * d_dot * d_dot + d_value
	  
	  dinc d_dot
    endw    

    $inp s_any, "The value of the string " + s_string + ", is=" + d_value
ends sub_string_value


subr sub_characters
'updated 2005/10/12, 2000/12/15
    vari d_any, s_any, d_dot, s_dot, s_out
    vari s_char, d_char, d_beg, d_end, s_pick
    vari d_yesfile, s_file, s_number

    d_beg = 32
    d_end = 128
    s_out = "1=chars 0/31, 2=chars 32/128, 3=chars 129/193"
    $app s_out, ", 4=chars 194/255"
    $inp s_pick, s_out

    $ift s_pick = "1"
	  d_beg = 0
	  d_end = 31
    endi
    $ift s_pick = "2"
	  d_beg = 32
	  d_end = 128
    endi
    $ift s_pick = "3"
	  d_beg = 129
	  d_end = 193
    endi
    $ift s_pick = "4"
	  d_beg = 194
	  d_end = 255
    endi

    d_yesfile = 2
    $inp s_any, "1=output to a file"
    $ift s_any = "1"
	  $inp s_file, "enter filename"
	  d_yesfile = 1
    endi

    s_dot = sg_nothing
    d_dot = 0
    d_char = d_beg

    dwhi d_char <= d_end
	  dch$ s_char, d_char, 1
	  dto$ s_number, d_char, 3, 0

	  s_out = s_number + "='" + s_char + "'"
	  dift d_yesfile = 1
		fapp d_any, s_file, s_out
		dbad d_any = 0
	  endi

	  $app s_dot, "  " + s_out
	  dinc d_dot

	  dift d_dot >= 6
		$out s_dot
		d_dot = 0
		s_dot = sg_nothing
	  endi

	  dinc d_char
    endw
    $len d_any, s_dot
    dift d_any > 0: $out s_dot

    $inp s_any, "return"
ends sub_characters


subr sub_compare_two_files
'updated 2007/03/09, 2007/03/08, 2006/04/04, 2006/04/02, 2000/12/15
'compare two files
    vari d_any, s_any, d_dot, s_dot
    vari s_file1, s_file2, d_byte, d_loop
    vari s_line1, s_line2, d_grab, d_long
    vari s_numbers, d_process, d_ctrec
    vari d_tap, s_tap1, s_tap2

    d_process = 1
    s_numbers = "1234567890123456789012345678901234567890"
    $app s_numbers, s_numbers
    $cut s_numbers, s_numbers, 1, 70

    dift d_process = 1
        $inp s_file1, "enter the name of file1"
	  $ift s_file1 = "*": dinc d_process
    endi
    dift d_process = 1
        $inp s_file2, "enter the name of file2"
	  $ift s_file2 = "*": dinc d_process
    endi
    dift d_process = 1
	  d_grab = 70
        $inp s_any, "enter record length including crlf"
	  $ift s_any = "*": dinc d_process
	  $isd d_any, s_any
	  dift d_any = 1: $tod d_grab, s_any
    endi

    d_ctrec = 0
    d_byte = 1
    d_loop = d_process
    dwhi d_loop = 1
	  dinc d_ctrec

	  s_line1 = sg_nothing
	  s_line2 = sg_nothing
	  frea s_line1, s_file1, d_byte, d_grab
	  frea s_line2, s_file2, d_byte, d_grab

	  $len d_long, s_line1
	  dift d_long > 0
	      $ift s_line1 = s_line2
		    $out "OK record compare=" + d_ctrec
	      else
		    $out "different record=" + d_ctrec
		    d_dot = 1
		    d_tap = 1
		    dwhi d_tap <= d_long
			  $cut s_tap1, s_line1, d_tap, 1
			  $cut s_tap2, s_line2, d_tap, 1
			  $ift s_tap1 <> s_tap2
				d_dot = d_tap
				d_tap = d_long
			  endi

			  dinc d_tap
		    endw

		    $out "difference after byte=" + d_dot

		    $out s_file1 + "=" 
		    d_dot = 1
		    dwhi d_dot <= d_grab
			  $cut s_any, s_line1, d_dot, 70
			  $out s_any
			  d_dot = d_dot + 70
		    endw
		    $out s_numbers

		    $out s_file2 + "="
		    d_dot = 1
		    dwhi d_dot < d_grab
			  $cut s_any, s_line2, d_dot, 70
			  $out s_any
			  d_dot = d_dot + 70
		    endw
		    $out s_numbers

		    $inp s_any, "difference above, * to end"
		    $ift s_any = "*": dinc d_loop
	      endi
	  else
		dinc d_loop
	  endi

	  d_byte = d_byte + d_grab
    endw
    $inp s_any, "done"
ends sub_compare_two_files


subr sub_lookup_one_file_in_another_file
'updated 2005/11/02
'2005/10/19, 2005/10/14, 2005/10/03, 2005/09/06, 2005/08/31
    vari d_any, s_any, d_dot, s_dot
    vari s_filename1, s_filename2
    vari s_filedata1, s_filedata2
    vari d_byte, d_good, d_loop, d_process, d_filebyte1
    vari s_record1, d_showfinds, d_long, d_ctfind, d_ctnofind
    vari d_tofile, s_tofilename, d_special, s_lookfor
    vari d_fieldbeg, d_fieldlong, d_onlyfield
    vari d_showlookfor

    d_process = 1
    dift d_process = 1
        $out "to lookup filename1 records in filename2 records"
        $inp s_filename1, "enter filename1"
	  $ift s_filename1 = "*": dinc d_process
    endi
    dift d_process = 1
        $inp s_filename2, "enter filename2"
	  $ift s_filename2 = "*": dinc d_process
    endi
    dift d_process = 1
	  flen d_any, s_filename1
	  $out "filename1=" + s_filename1 + ", length=" + d_any

        finp s_filedata2, s_filename2
        $len d_long, s_filedata2
        $out "filename2=" + s_filename2 + ", length=" + d_long

        d_showfinds = 1
        $inp s_any, "1=showfinds, 2=show not finds"
        $ift s_any = "2": d_showfinds = 2
	  $ift s_any = "*": dinc d_process
    endi
    dift d_process = 1
        d_tofile = 2
        $inp s_any, "1=results to a tofile"
	  $ift s_any = "*": dinc d_process
        $ift s_any = "1"
	      d_tofile = 1
	      $inp s_tofilename, "enter tofile name"
	      $ift s_any = "*": dinc d_process
		flen d_any, s_tofilename
		dift d_any >= 0
		    $inp s_any, "1=purge tofile=" + s_tofilename
		    $ift s_any = "1": fdel d_any, s_tofilename
		    $ift s_any = "*": dinc d_process
		endi
        endi
    endi
    dift d_process = 1
        d_special = 0
	  $out "special handling of file1 record"
	  $out "1=file1 has ssn in position 5 remove -"
	  $out "2=file1 has ssn in position 5 leave -"
	  $out "3=enter beg byte and length of field"
	  $out "4=enter beg byte and length, remove - in lookfor"
	  $inp s_any, "enter a number"
	  $ift s_any = "*": dinc d_process
	  $ift s_any = "1": d_special = 1
	  $ift s_any = "2": d_special = 2
	  $ift s_any = "3": d_special = 3
	  $ift s_any = "4": d_special = 4

	  dift d_special = 3
		d_fieldbeg = 0
		d_fieldlong = 0

		$inp s_any, "enter beginning byte of field"
		$tod d_fieldbeg, s_any

		$inp s_any, "enter length of field"
		$tod d_fieldlong, s_any
	  endi
	  dift d_special = 4
		d_fieldbeg = 0
		d_fieldlong = 0

		$inp s_any, "enter beginning byte of field"
		$tod d_fieldbeg, s_any

		$inp s_any, "enter length of field"
		$tod d_fieldlong, s_any
	  endi

	  d_onlyfield = 2
	  $inp s_any, "1=output only the field"
	  $ift s_any = "1": d_onlyfield = 1
    endi

    d_showlookfor = 2
    dift d_process = 1
	  $inp s_any, "1=show each s_lookfor field"
	  $ift s_any = "1": d_showlookfor = 1  
    endi

    d_ctfind = 0
    d_ctnofind = 0
    d_filebyte1 = 1
    d_loop = d_process
    dwhi d_loop = 1
	  d_good = 1
	  fsip s_record1, s_filename1, d_filebyte1
	  dift d_filebyte1 = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		dift d_special = 0: s_lookfor = s_record1
		dift d_special = 1
		    'ssn in position 5
		    $par s_lookfor, s_record1, ",", 5
		    $swp s_lookfor, "-", ""
		endi
		dift d_special = 2
		    'ssn in position 5 leave in -
		    $par s_lookfor, s_record1, ",", 5
		endi
		dift d_special = 3
		    'beginning byte in d_fieldbeg, long in d_fieldlong
		    $cut s_lookfor, s_record1, d_fieldbeg, d_fieldlong
		endi
		dift d_special = 4
		    'beginning byte in d_fieldbeg, long in d_fieldlong
		    'remove - in s_lookfor
		    $cut s_lookfor, s_record1, d_fieldbeg, d_fieldlong
		    $swp s_lookfor, "-", sg_nothing
		endi
	  endi
	  dift d_good = 1
		$trb s_lookfor, s_lookfor
		$len d_any, s_lookfor
		dift d_any = 0: dinc d_good
	  endi
	  dift d_good = 1
		dift d_showlookfor = 1
		    $out "looking for='" + s_lookfor + "'"
		endi

		$lok d_byte, s_filedata2, 1, s_lookfor
		dift d_showfinds = 1
		    dift d_byte > 0
			  dinc d_ctfind
			  $out "found=" + s_record1

dift d_onlyfield = 1
    $cut s_record1, s_record1, d_fieldbeg, d_fieldlong
endi

			  dift d_tofile = 1
				fapp d_any, s_tofilename, s_record1
				dbad d_any = 0
			  endi
		    else
			  dinc d_ctnofind
		    endi
		else
		    dift d_byte = 0
			  dinc d_ctnofind
			  $out "no find=" + s_record1
dift d_onlyfield = 1
    $cut s_record1, s_record1, d_fieldbeg, d_fieldlong
endi
			  dift d_tofile = 1
				fapp d_any, s_tofilename, s_record1
				dbad d_any = 0
			  endi
		    else
			  dinc d_ctfind
		    endi
		endi
	  endi	  
    endw
    $out "find count=" + d_ctfind + ", no find=" + d_ctnofind
    $inp s_any, "done"
ends sub_lookup_one_file_in_another_file


subr sub_random
'updated 2000/12/15
'random numbers
    vari d_randh1, d_randh2, d_rand1, d_rand2, d_max, d_min
    vari d_gen, d_mult, d_add, d_mod1, d_mod2
    vari d_loop, d_count, d_tell
    vari s_num1, s_num2, s_num3, s_num4, s_num5, s_num6

    '3,17 did 458052
    '3,19 did 672311
    '3,23 did 1349393
    $tod d_gen, "123456791"
    $tod d_mult, "3"
    $tod d_add, "23"
    $tod d_mod1, "123456791"
    $tod d_mod2, "1000000"
    d_randh1 = 0
    d_randh2 = 0
    d_rand1 = 0
    d_rand2 = 0
    d_min = 10000 * 10000
    d_max = - 10000 * 10000

    d_count = 1
    d_loop = 1
    dwhi d_loop = 1
	  d_rand2 = d_rand1

	  d_gen = d_gen + d_add * d_mult
	  d_gen = d_gen % d_mod1

	  d_rand1 = d_gen % d_mod2

	  dift d_count > 1000
	      dift d_max < d_rand1: d_max = d_rand1
	      dift d_min > d_rand1: d_min = d_rand1
		
		d_tell = d_count % 10000
		dift d_tell = 0
	          dto$ s_num1, d_count, 9, 0
	          dto$ s_num2, d_min, 9, 0
	          dto$ s_num3, d_max, 9, 0
	          dto$ s_num4, d_randh2, 9, 0
		    dto$ s_num5, d_randh1, 9, 0
	          dto$ s_num6, d_rand1, 9, 0
	          $out s_num1+s_num2+s_num3+s_num4+s_num5+s_num6
		endi
	  endi

	  dift d_rand1 = d_randh1
		dift d_rand2 = d_randh2: dinc d_loop
	  endi
	  dift d_count = 1000
		d_randh1 = d_rand1
		d_randh2 = d_rand2
	  endi
	  dinc d_count
    endw
    dto$ s_num1, d_count, 9, 0
    dto$ s_num2, d_min, 9, 0
    dto$ s_num3, d_max, 9, 0
    dto$ s_num4, d_randh2, 9, 0
    dto$ s_num5, d_randh1, 9, 0
    dto$ s_num6, d_rand1, 9, 0
    $out s_num1 + s_num2 + s_num3 + s_num4 + s_num5 + s_num6
    $inp s_num1, "return"
ends 'sub_random


subr sub_fibonacci
'updated 2000/12/15
'find fibonacci numbers
    vari d_any, s_any, d_dot, s_dot
    vari d_count, d_num1, d_num2, d_ratio, d_loop, d_five

    dpow d_five, 5, 0.5
    $out "the square root of 5=" + d_five
    d_five = d_five - 1 / 2  
    d_num2 = 1
    d_num1 = 1
    d_count = 0
    d_loop = 1
    dwhi d_loop = 1
	  dinc d_count
	  d_ratio = d_num2 / d_num1
	  s_any = d_count + ".  " + d_num2 + " / " + d_num1 + "  " + d_ratio
	  $app s_any, "  " + d_five
	  $out s_any
	  d_any = d_num1 + d_num2
	  d_num2 = d_num1
	  d_num1 = d_any
	  d_any = d_count % 10
	  dift d_any = 0
		$inp s_any, "return for more, * to end"
		$ift s_any = "*": dinc d_loop
	  endi	  
    endw
ends sub_fibonacci


subr sub_test_stod
'updated 2002/07/31
    vari s_any, d_any, s_dot, d_dot
    vari s_input

    s_input = "1"
    $whi s_input <> "*"
	  $inp s_input, "enter a string to test $tod"
	  $tod d_dot, s_input
	  $out "d_dot=" + d_dot
	  $out "s_input=" + s_input
    endw   
ends sub_test_stod


subr sub_doubling
'updated 2000/12/15
    vari d_double, d_half, d_linecount, d_count
    vari d_loop, s_input

    d_loop = 1
    d_double = 1
    d_half = 0
    d_count = 1
    d_linecount = 0
    dwhi d_loop = 1
        d_double = d_double * 2
	  d_half = 1 / d_double + d_half

	  $out d_count + "   " + d_double + "   " + d_half
        
        dinc d_linecount
        dift d_linecount > 9
            d_linecount = 0
		$inp s_input,"Pause, * to end"
		$ift s_input = "*": dinc d_loop
        endi

	  dinc d_count
    endw
ends sub_doubling


subr sub_adding_rounding
'updated 2003/09/14
'add up floating point numbers and rounding
    vari d_any, s_any, d_dot, s_dot, s_out
    vari d_loop, d_count, d_totcount
    vari d_number, s_pick, d_pick, d_good
    vari d_total1, d_total2, d_total3

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1
	  d_number = 0
	  $inp s_any, "enter number to total up"
	  $isd d_any, s_any
	  dift d_any = 1
	      $tod d_number, s_any
	      $trb s_any, s_any
	  else
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		d_totcount = 0
		$inp s_any, "enter number of times to total"
		$isd d_any, s_any
		dift d_any = 1: $tod d_totcount, s_any
	  endi
	  dift d_good = 1
		d_count = 0
		d_total1 = 0
		d_total2 = 0
		d_total3 = 0
		dwhi d_count < d_totcount
		    d_total1 = d_total1 + d_number
		    d_total2 = d_total2 + d_number
		    d_total3 = d_total3 + d_number

		    'round d_total2
		    d_total2 = d_total2 * 100
		    drou d_total2, d_total2
		    d_total2 = d_total2 / 100

		    'truncate d_total3
		    d_total3 = d_total3 * 100
		    dtru d_total3, d_total3
		    d_total3 = d_total3 / 100

		    dinc d_count
		endw
		s_out = "adding " + d_number + " up " + d_totcount
		$app s_out, " times"
		$out s_out
		$out "rounding and truncating is to cents"
		$out "just adding the total is " + d_total1 
		$out "   rounding the total is " + d_total2 
		$out " truncating the total is " + d_total3 
		$inp s_any, "return"
	  endi
    endw
ends sub_adding_rounding


subr sub_tag_numbers
'updated 2006/05/24, 2005/09/05, 2005/04/18, 2001/03/05
'Tag numbers
    vari d_any, s_any, d_dot, s_dot
    vari d_total, d_count, d_date, s_date
    vari d_lines, s_number, s_out
    vari d_tofile, s_filename

    d_total = 1
    $inp s_any, "How many?"
    $isd d_any, s_any
    dift d_any = 1: $tod d_total, s_any

    d_date = 60500
    $inp s_any, "Enter begining date, ie. 060500"
    $isd d_any, s_any
    dift d_any = 1: $tod d_date, s_any

    d_tofile = 1

    dift d_tofile = 1
	  $inp s_filename, "enter the name of the file"
	  flen d_any, s_filename
	  dift d_any >= 0
		$inp s_any, "1 = purge existing file"
		$ift s_any = "1": fdel d_any, s_filename
	  endi
    endi

    d_lines = 0
    d_count = 1
    dwhi d_count <= d_total
	  d_any = d_date \ 2
	  dto$ s_dot, d_any, 0, 0
	  
	  d_any = 1
	  dwhi d_any > 0
		$lok d_any, s_dot, 1, "0"
		dift d_any > 0: $del s_dot, d_any, 1
	  endw

	  $sor s_number, s_dot, 1
	  $tod d_any, s_number
	  dto$ s_number, d_any, 8, 0
   
	  dto$ s_date, d_date, 0, 0
	  $len d_any, s_date
	  dift d_any = 5: s_date = "0" + s_date	

	  $ins s_date, 5, "/"
	  $ins s_date, 3, "/"

	  dto$ s_dot, d_count, 4, 0
	  s_out = s_dot + ". " + s_date + s_number
	  
        $out s_out

	  fapp d_any, s_filename, s_out

	  d_date = d_date + 100
	  d_any = d_date % 10000 \ 100
	  dift d_any > 31
		d_date = d_date - 3100 + 10000
		d_any = d_date \ 10000
		dift d_any > 12
		    'subtract 120000 and add 1
		    d_date = d_date - 60000 - 60000 + 1
		endi
	  endi
	  
	  dinc d_count
    endw    

    $inp s_any, "return"
ends sub_tag_numbers


subr sub_add_one
'updated 2000/12/15
'add one to a big number
    vari d_any, s_any, d_dot, s_dot
    vari d_number, s_number, d_delta, s_delta
    vari d_loop, d_good, d_count, d_old
    vari d_round, d_dinc, d_integerout

    d_good = 1

    $inp s_number, "Enter the number"
    $isd d_any, s_number
    dift d_any <> 1: dinc d_good

    dift d_good = 1
	  $inp s_any, "1 = use dinc instead of +"
	  d_dinc = 2
	  $ift s_any = "1": d_dinc = 1

	  $inp s_any, "1 = round to whole number after each add"
	  d_round = 2
	  $ift s_any = "1": d_round = 1

	  $inp s_any, "1 = output as an integer"
	  d_integerout = 2
	  $ift s_any = "1": d_integerout = 1

	  $tod d_number, s_number
	  d_old = d_number

	  $out "show the incremented number and the delta amount"

	  d_delta = d_number - d_old
	  ded$ s_number, d_number, 20, 20
	  ded$ s_delta, d_delta, 20, 20
	  $out "n=" + s_number + ", d=" + s_delta

	  d_count = 0
	  d_loop = 1

	  dwhi d_loop = 1
		dift d_dinc = 1
		    d_number = d_number + 1
		else
		    dinc d_number
		endi

		dift d_round = 1: d_number = d_number \ 1

		d_delta = d_number - d_old

		dift d_integerout = 1
		    ded$ s_number, d_number, 0, 0
		    ded$ s_delta, d_delta, 0, 0
		else
		    ded$ s_number, d_number, 0, 20
		    ded$ s_delta, d_delta, 0, 20
		endi

		$out "n=" + s_number + ", d=" + s_delta

		dinc d_count
		dift d_count > 5
		    d_count = 0
		    
		    s_any = "more, * to end, round=" + d_round
		    $app s_any, ", dinc=" + d_dinc
		    $app s_any, ", as integer=" + d_integerout
		    $inp s_any, s_any
		    $ift s_any = "*": dinc d_loop
		endi		
	  endw
    endi
ends sub_add_one


subr sub_double_math
'updated 2005/04/18, 2000/12/15
'do math with doubles
    vari d_any, s_any, d_dot, s_dot, d_toe, d_pie
    vari d_num1, d_num2, s_operator, d_answer, d_loop, s_num1
    vari s_asterisks, s_pick, d_pick, d_total, d_count

    $ch$ s_asterisks, "*", 76

    $out "2 = double math"
    $out "3 = adding machine"
    $out "4 = test %"
    $out "5 = power or exponentiation"
    $inp s_pick, "choose a number"

    $isd d_any, s_pick
    d_pick = 0
    dift d_any = 1: $tod d_pick, s_pick    

    dift d_pick = 2
    d_loop = 1
    dwhi d_loop = 1
	  $inp s_num1, "enter the first number, * to end"
	  $ift s_num1 = "*"
		dinc d_loop
	  else
	      $tod d_num1, s_num1
		$out "The first number=" + d_num1
		$out " "

	      $inp s_num1, "enter the second number"
	      $tod d_num2, s_num1	   
		$out "The second number=" + d_num2
		$out " "

	      $inp s_operator, "enter the operator, +-*/"

	      $ift s_operator = "+": d_answer = d_num1 + d_num2
	      $ift s_operator = "-": d_answer = d_num1 - d_num2
	      $ift s_operator = "*": d_answer = d_num1 * d_num2
	      $ift s_operator = "/": d_answer = d_num1 / d_num2

		$out s_asterisks
	      $out d_num1+" "+s_operator+" "+d_num2+" = "+d_answer
		$out s_asterisks
		$out " "
	  endi
    endw
    endi

    dift d_pick = 3
	  d_count = 0
	  d_total = 0
	  d_loop = 1
	  dwhi d_loop = 1
		ded$ s_num1, d_total, 0, 0
		s_any = s_num1 + " = Total of " + d_count + " terms, "
		$app s_any, "enter a number to be added in"

		$inp s_num1, s_any
		$isd d_any, s_num1

		dift d_any = 1
		    $tod d_any, s_num1
		    d_total = d_total + d_any
		    dinc d_count
		else
		    $out s_num1 + " is not numeric"
		    $ift s_num1 = "*": dinc d_loop
		endi
	  endw
	  ded$ s_num1, d_total, 0, 0
	  $inp s_any, s_num1 + " = total of " + d_count + " terms"
    endi
    dift d_pick = 4
	  d_loop = 1
	  dwhi d_loop = 1
		$inp s_any, "test mod, enter first number, * to end"
		$isd d_any, s_any
		dift d_any = 1
		    $tod d_num1, s_any

		    d_any = d_num1 \ 1
		    $out d_num1 + " rounded by 0 is " + d_any

		    d_any = d_num1 \ 1
		    $out d_num1 + " rounded by 2 is " + d_any

		    d_any = d_num1 \ 1
		    $out d_num1 + " truncated by 0 is " + d_any

		    d_any = d_num1 \ 1
		    $out d_num1 + " truncated by 2 is " + d_any

		    $inp s_any, "test mod, enter second number, * to end"
		    $isd d_any, s_any
		    dift d_any = 1
			  $tod d_num2, s_any

		        d_any = d_num2 \ 1
		        $out d_num2 + " rounded by 0 is " + d_any

		        d_any = d_num1 \ 1
		        $out d_num1 + " rounded by 2 is " + d_any

		        d_any = d_num2 \ 1
		        $out d_num2 + " truncated by 0 is " + d_any
			  
			  d_any =  d_num1 % d_num2
			  $out d_num1 + " mod " + d_num2 + " = " + d_any
		    else
			  $out "bad number = " + s_any
			  dinc d_loop
		    endi
		else
		    $out "bad number = " + s_any
		    dinc d_loop
		endi
	  endw
    endi
    dift d_pick = 5
	  d_loop = 1
	  dwhi d_loop = 1
		$inp s_any, "enter first number to be exponentiated, * to end"
		$isd d_any, s_any
		dift d_any = 1
		    $tod d_num1, s_any

		    $out "the first number is " + d_num1

		    $inp s_any, "enter the exponent, * to end"
		    $isd d_any, s_any
		    dift d_any = 1
			  $tod d_num2, s_any

		        $out "the second number is " + d_num2
			  dpow d_any, d_num1, d_num2
			  s_any = d_num1 + " raised to " + d_num2 
			  $app s_any, " is " + d_any
			  $out s_any
		    else
			  $out "bad number = " + s_any
			  dinc d_loop
		    endi
		else
		    $out "bad number = " + s_any
		    dinc d_loop
		endi
	  endw
    endi
    dift d_pick = 6 
	  d_loop = 1
	  dwhi d_loop = 1
		$out "enter a number, * to end"
		$out "2.8 is a good one to try"
		$inp s_any, "12345678901234567890"
		$isd d_any, s_any
		dift d_any = 1
		    $tod d_num1, s_any

		    d_dot = 0
		    dwhi d_dot <= 15
		        d_any = d_num1 \ 1
		        s_any = d_num1 + " rounded to " + d_dot 
			  $app s_any, " decimals is " + d_any
			  $out s_any
			  dinc d_dot
		    endw

		    $inp s_any, "return to see \ 1"
		    d_dot = 0
		    dwhi d_dot <= 15
		        d_any = d_num1 \ 1
		        s_any = d_num1 + " truncated to " + d_dot 
			  $app s_any, " decimals is " + d_any
			  $out s_any
			  dinc d_dot
		    endw

		    $inp s_any, "return to see dto$"
		    d_dot = 0
		    dwhi d_dot <= 15
		        dto$ s_dot, d_num1, 20, d_dot
			  $trb s_dot, s_dot
		        s_any = d_num1 + " using dto$ with " + d_dot 
			  $app s_any, " decimals is " + s_dot
			  $out s_any
			  dinc d_dot
		    endw
		else
		    dinc d_loop
		endi
	  endw
    endi
ends sub_double_math


subr sub_large_string
'updated 2000/12/15
    vari s_any, d_any
    vari s_test,d_loop,d_long,s_take,d_time,s_date,d_sec1,d_sec2

    s_test = "1234567890"
    d_loop = 1
    dwhi d_loop = 1
	  dsec d_sec1

	  $app s_test, s_test
	  dsec d_sec2

	  d_sec2 = d_sec2 - d_sec1
	  $out "Seconds to build=" + d_sec2
	  $len d_long, s_test
	  $out "The length is=" + d_long
	  $inp s_take, "Hit return to double the string, * to end"
	  $ift s_take  =  "*": dinc d_loop
    endw
    $inp s_take, "enter Z to zero the string length"
    $ift s_take = "Z": s_test = sg_nothing
ends sub_large_string


subr sub_time_watch
'updated 2000/12/15
'watch time change
    vari d_any
    vari s_time, s_newtime, d_good, d_count

    s_time = "x"
    d_good = 1
    dwhi d_good = 1
	  $dat s_newtime

	  $ift s_newtime <> s_time
		dinc d_count
		s_time = s_newtime
		$out d_count + ". " + s_newtime
	  endi 
    endw
ends sub_time_watch


subr sub_lines_out
'updated 2000/12/15
'output lines 971/993 in the array to the screen
    vari d_index, s_line

    d_index = 993
    dwhi d_index >= 971
	  ito$ s_line, d_index
	  $out s_line

	  ddec d_index
    endw    
ends sub_lines_out


subr sub_sam_bass
'updated 2006/08/22, 2006/08/21, 2004/10/21
'sam_bass or not sam_bass
    vari d_any, s_any, d_dot, s_dot, s_out
    vari d_grab, s_file1, s_file2, d_yessambass
    vari d_char, s_char, d_shift, d_good, d_match
    vari d_byte, s_line, d_loop, d_long, d_filelen
    vari d_sambassnew, d_sambassold, d_sambasscount
    vari d_high, d_low, d_onemillion, d_big
    vari s_alpha, s_word, d_process, d_total, d_action

    d_process = 1
    $tod d_big, "700000001"

    $inp s_any, "1 = test"
    $ift s_any = "*": dinc d_process
    $ift s_any = "1"
	  $inp s_any, "enter sambass ie. 180,196,334 or 122,976,458"
	  $ift s_any = "*": dinc d_process
	  $tod d_sambassnew, s_any

	  dpow d_onemillion, 10, 6
	  dpow d_low, 10, 10
	  d_total = 0
	  d_high = 0
        d_match = 0
	  d_sambasscount = 0
	  d_sambassold = d_sambassnew
	  d_loop = d_process

	  dwhi d_loop = 1
		d_action = 0

	      d_sambassnew = d_sambassnew * 3 + 35731 % d_big

	      dinc d_sambasscount
		d_total = d_total + d_sambassnew

		dift d_sambassnew > d_high
		    d_high = d_sambassnew
		    d_action = 1
		endi
		dift d_sambassnew < d_low
		    d_low = d_sambassnew
		    d_action = 1
		endi

		'tell every millionth
		d_any = d_sambasscount % d_onemillion
		dift d_any = 0: d_action = 1

		'tell if match
	      dift d_sambassnew = d_sambassold: d_action = 1

		dift d_action = 1
		    ded$ s_out, d_sambasscount, 0, 0

		    ded$ s_any, d_sambassnew, 0, 0
		    $app s_out, ", now=" + s_any

		    ded$ s_any, d_low, 0, 0
		    $app s_out, ", lo=" + s_any

		    ded$ s_any, d_high, 0, 0
		    $app s_out, ", hi=" + s_any

		    d_any = d_total / d_sambasscount
		    ded$ s_any, d_any, 0, 0
		    $app s_out, ", ave=" + s_any

		    $out s_out
		endi

	      dift d_sambassnew = d_sambassold
		    $inp s_any, "match"
		    dinc d_loop
		    dinc d_process
	      endi
	  endw
    endi

    dift d_process = 1
        $inp s_file1, "Enter the name of the first file"
	  $ift s_file1 = "*": dinc d_process
    endi
    dift d_process = 1
        $inp s_file2, "Enter the name of the second file"
	  $ift s_file2 = "*": dinc d_process
    endi

    dift d_process = 1
        $inp s_word, "Enter a word, alphanumeric please"
	  $ift s_word = "*": dinc d_process
    endi
    dift d_process = 1
        d_yessambass = 2
        $inp s_any, "1=to sam bass, 2=from sam_bass"
	  $ift s_any = "*": dinc d_process
        $ift s_any = "1": d_yessambass = 1
    endi

    'numbers are 48/57
    'letters are 65/90
    'char are 33/126
    'the space is 32

    dift d_process = 1
        $cup s_word, s_word
        $trb s_word, s_word
        $cut s_word, s_word, 1, 10

        'validate
	  $len d_long, s_word
        s_alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
	  d_sambassnew = 0
        d_dot = 1

        dwhi d_dot <= d_long
	      $cut s_char, s_word, d_dot, 1
	      $lok d_char, s_alpha, 1, s_char
		dift d_char > 0
		    d_sambassnew = d_sambassnew * 5 + d_char
		endi
		ded$ s_any, d_sambassnew, 0, 0
		$out s_any

	      dinc d_dot
        endw

	  d_sambassnew = d_sambassnew % d_big
	  d_sambassold = d_sambassnew
	  d_sambasscount = 1
    endi
    dift d_process = 1
        ded$ s_any, d_sambassnew, 0, 0
        $inp s_any, "d_sambassnew=" + s_any + ", * to end"
        $ift s_any = "*": dinc d_process
    endi
    dift d_process = 1
	  'validate the file names
	  $cup s_file1, s_file1
	  $cup s_file2, s_file2

	  flen d_filelen, s_file1
	  dift d_filelen < 1
		dinc d_process
		$out "the first file does not exist"
	  endi
    endi

    dift d_process = 1
	  fdel d_any, s_file2

	  d_grab = 4000
	  d_byte = 1
    endi

    d_loop = d_process
    dwhi d_loop = 1
	  $out d_byte
	  frea s_line, s_file1, d_byte, d_grab
	  $len d_long, s_line
	  dift d_long > 0
		d_dot = 1
		dwhi d_dot <= d_long
		    d_sambassnew = d_sambassnew * 3 + 17 % d_big

		    dinc d_sambasscount
		    dift d_sambassnew = d_sambassold
			  ded$ s_any, d_sambasscount, 0, 0
			  ded$ s_dot, d_sambassnew, 0, 0
			  $out "count=" + s_any + ", sambass=" + s_dot
		    endi

		    $cut s_char, s_line, d_dot, 1
		    $chd d_char, s_char

		    dift d_char >= 32
			  dift d_char <= 126
				
				d_shift = d_sambassnew % 95 + 1

		    		dift d_yessambass = 1
				    d_char = d_char + d_shift			
			      else
				    d_char = d_char - d_shift			
			      endi 

				dift d_char < 32: d_char = d_char + 95
				dift d_char > 126: d_char = d_char - 95

				'put back in
				dch$ s_char, d_char, 1
				$rep s_line, d_dot, s_char
			  endi
		    endi
		    dinc d_dot
		endw
		fwri d_any, s_file2, d_byte, s_line		
		dbad d_any = 0
	  endi
	  d_byte = d_byte + d_grab
	  dift d_byte > d_filelen: dinc d_loop
    endw

    $inp s_any, "done"
ends sub_sam_bass


subr sub_hash
'updated 2005/02/08
    vari d_any, s_any, d_dot, s_dot, s_out
    vari d_loop1, d_loop2, s_string, d_hash, d_value
    vari d_good, d_byte, s_byte, d_char, d_long
    vari d_big

    d_loop1 = 1
    dwhi d_loop1 = 1
	  d_good = 1
	  $inp s_string, "enter string, * to end"
	  $ift s_string = "*"
		dinc d_loop1
		dinc d_good
	  endi
	  dift d_good = 1
		d_hash = 0
		$tup s_string, s_string
		$len d_long, s_string
		d_byte = 1
		d_loop2 = 1
		dwhi d_loop2 = 1
		    $cut s_byte, s_string, d_byte, 1
		    $chd d_char, s_byte
		    '48 to 57 is 0 to 9
		    '65 to 90 is A to Z
		    '95 is _
		    d_value = 0
		    dift d_char >= 48
			  dift d_char <= 95: d_value = d_char
		    endi
		    d_any = d_value * d_value * d_value
		    d_hash = d_hash * 2 + d_any

		    dpow d_big, 10, 9
		    dift d_hash > d_big: d_hash = d_hash % d_big
		    ded$ s_any, d_hash, 0, 0
		    $out s_byte + " " + s_any
		    
		    dinc d_byte
		    dift d_byte > d_long: dinc d_loop2		
		endw
	  endi
    endw
ends sub_hash

subr sub_file_total_characters
'updated 2005/07/24
    vari s_any, d_any, s_dot, d_dot
    vari s_filename, s_record, d_filebyte
    vari d_loop, d_good, d_long
    vari d_chartotal, d_count, d_lines

    $inp s_filename, "enter filename"

    d_filebyte = 1
    d_lines = 0
    d_chartotal = 0
    d_count = 0
    d_loop = 1
    dwhi d_loop = 1
	  dinc d_lines
	  d_any = d_lines % 100
	  dift d_any = 0: $sho "lines=" + d_lines

	  d_good = 1
	  fsip s_record, s_filename, d_filebyte
	  dift d_filebyte = 0
		dinc d_loop
		dinc d_good
	  endi
	  dift d_good = 1
		$trb s_record, s_record
		$len d_long, s_record

		d_dot = 1
		dwhi d_dot <= d_long
		    dinc d_count
		    $cut s_dot, s_record, d_dot, 1
		    $chd d_any, s_dot
		    dift d_any > 32
			  d_chartotal = d_chartotal + d_any
		    endi
		    dinc d_dot
		endw
	  endi
    endw

    ded$ s_any, d_chartotal, 0, 0
    $out "total characters=" + s_any
    ded$ s_any, d_count, 0, 0
    $out "count=" + s_any
    ded$ s_any, d_lines, 0, 0
    $out "lines=" + s_any

    $inp s_any, "done"
ends sub_file_total_characters


subr sub_prog_teapro_indent
'updated 2008/01/10
'2007/03/26, 2007/03/25, 2006/07/13, 2005/01/16, 2004/10/21
'indent a Teapro program
    vari d_any, s_any, d_dot, s_dot
    vari s_filename1, s_filename2, d_filebyte
    vari d_beg, d_end, s_command
    vari d_process, d_shift, d_output, d_show
    vari d_delta, d_spaces, s_spaces, d_inquote, s_quote
    vari s_line, d_good, d_loop, d_count
    vari d_record, s_record, d_byte, s_byte, d_long

    d_process = 1
    dift d_process = 1
	  $inp s_filename1, "input filename"
	  $ift s_filename1 = "*": dinc d_process
    endi
    dift d_process = 1
	  $inp s_filename2, "output filename"
	  $ift s_filename2 = "*": dinc d_process
    endi
    dift d_process = 1
	  flen d_any, s_filename2
	  dift d_any >= 0
		$inp s_any, "1=purge old file=" + s_filename2
		$ift s_any = "*": dinc d_process
		$ift s_any = "1": fdel d_any, s_filename2
	  endi
    endi
    dift d_process = 1
	  d_shift = 4
	  $inp s_any, "enter shift amount, default=4"
	  $ift s_any = "*": dinc d_process
	  $isd d_any, s_any
	  dift d_any = 1: $tod d_shift, s_any	  
    endi

    d_count = 0
    d_spaces = 0
    d_record = 0
    d_loop = d_process

    dwhi d_loop = 1
	  d_delta = 0
	  d_good = 1
	  d_output = 1
	  d_show = 2

	  fsip s_record, s_filename1, d_filebyte

	  dift d_filebyte = 0
		dinc d_good
		dinc d_output
		dinc d_loop
	  endi

	  dift d_good = 1
		dinc d_record
		d_any = d_record % 100
		dift d_any = 0: $sho "record=" + d_record

		'get the line
		$bes s_record, s_record
		$trb s_line, s_record

		'do nothing to lines beginning with <
		$cut s_byte, s_line, 1, 1
	      $ift s_byte = "<": dinc d_good

		'do nothing to blank lines
		$len d_any, s_line
		dift d_any = 0
		    s_line = " "
	          dinc d_good
		endi
        endi
	  dift d_good = 1
		'count lines to shift
		dinc d_count

		$cut s_command, s_line, 1, 4
		$cup s_command, s_command

		$ift s_command = "SUBR"
		    d_spaces = 0
		    d_delta = d_shift
		    d_show = 1
		endi

		$lok d_dot, "DIFT.$IFT", 1, s_command
		dift d_dot > 0
		    $lok d_dot, s_line, 1, ":"
		    dift d_dot = 0
			  d_delta = d_shift
			  d_show = 1
		    else
			  'is the colon in quotes or not
			  'is there a colon not in quotes
			  d_inquote = 2
			  s_quote = "#"
			  d_delta = d_shift
			  d_show = 1
			  $len d_long, s_line
			  d_byte = 1

			  dwhi d_byte <= d_long
				'do we have a quote
				$cut s_byte, s_line, d_byte, 1
				d_dot = 2
				$ift s_byte = #"#: d_dot = 1
				$ift s_byte = "#": d_dot = 1
				dift d_dot = 1
				    dift d_inquote = 1
					  $ift s_byte = s_quote 
						dinc d_inquote
					  endi 
				    else
					  d_inquote = 1
					  s_quote = s_byte
				    endi
				endi

				$ift s_byte = ":"
				    dift d_inquote <> 1
					  d_delta = 0
					  dinc d_show
				    endi
				endi

				dinc d_byte
			  endw
		    endi
		endi
	
		$ift s_command = "ELSE"
		    d_spaces = d_spaces - d_shift
		    d_delta = d_shift
		    d_show = 1
		endi

		$ift s_command = "DWHI"
		    d_delta = d_shift
		    d_show = 1
		endi

		$ift s_command = "$WHI"
		    d_delta = d_shift
		    d_show = 1
		endi

		s_dot = "ENDI.ENDW"
		$lok d_dot, s_dot, 1, s_command
		dift d_dot > 0
		    d_spaces = d_spaces - d_shift
		    d_show = 1
		endi

		$ift s_command = "ENDS"
		    d_spaces = 0
		    d_show = 1
		endi
	  endi
	  dift d_good = 1
		'do the indentation spaces
	      $ch$ s_spaces, " ", d_spaces		
	      s_line = s_spaces + s_line
	      d_spaces = d_spaces + d_delta
	  endi
	  dift d_output = 1
		'output the record
		fapp d_any, s_filename2, s_line
		dbad d_any = 0
	  endi
        dift d_show = 1
		$out s_line
	  endi
    endw

    $inp s_any, "done, count=" + d_count
ends sub_prog_teapro_indent


subr sub_xyzmath
'updated 2005/08/07, 2005/04/18, 2004/01/04
'solve a multi number math expression in sg_pass1
'the format is: x=123*567+4.6 etc or y=123*567+4.6
'put answer in dg_xvalue, dg_yvalue, dg_zvalue
    vari d_any, s_any, d_dot, s_dot, s_out, s_lok
    vari d_good, d_long, d_loop, d_error, d_lines
    vari s_line, d_number, s_operator, d_answer, s_xyzvalue
    vari s_work, d_byte, s_term, d_process, s_command, s_aster

    s_command = sg_pass1
    $cup s_line, s_command
    $trb s_line, s_line

    $ift s_line = "XYZ": s_line = "X=X"

    'do we have x=, or y= or z=
    d_process = 2
    $cut s_any, s_line, 1, 2
    $ift s_any = "X=": d_process = 1 
    $ift s_any = "Y=": d_process = 1
    $ift s_any = "Z=": d_process = 1

    dwhi d_process = 1
        'x is in dg_xvalue, y is in dg_yvalue, z in dg_zvalue

	  'remove commas and blanks
	  d_loop = 1
	  dwhi d_loop = 1
		dinc d_loop

		$lok d_dot, s_line, 1, ","
		dift d_dot > 0
		    $del s_line, d_dot, 1
		    d_loop = 1
		endi

		$lok d_dot, s_line, 1, " "
		dift d_dot > 0
		    $del s_line, d_dot, 1
		    d_loop = 1
		endi
	  endw

	  'colon delimited into sg_xyzmath
	  $app sg_xyzmath, s_line + ":"

        'remove the x= or y= at the beginning
        $cut s_work, s_line, 3, 100
	  $cut s_any, s_work, 1, 1

	  'put on + if needed
	  $ift s_any <> "+"
		$ift s_any <> "-": s_work = "+" + s_work
	  endi
        $app s_work, ";"

        $len d_long, s_work
        d_error = 2
        d_byte = 2
        d_answer = 0
        d_loop = 1

        dwhi d_loop = 1
		'do we have the next operator in d_byte
	      $cut s_dot, s_work, d_byte, 1
		s_lok = "+-*/\^%;"
	      $lok d_any, s_lok, 1, s_dot

	      dift d_any > 0
		    'we have the location of the next operator
		    d_long = d_byte - 2

		    'the current operator is in 1
		    'get the number or x or y
		    $cut s_term, s_work, 2, d_long

		    'is this string a number
		    $isd d_good, s_term
		    dift d_good = 1
		        $tod d_number, s_term
		    else
		        'if X then use the xvalue from previous
		        $ift s_term = "X"
			      d_number = dg_xvalue
			      d_good = 1
		        endi
		        $ift s_term = "Y"
			      d_number = dg_yvalue
			      d_good = 1
		        endi
		        $ift s_term = "Z"
			      d_number = dg_zvalue
			      d_good = 1
		        endi
			  dift d_good <> 1: d_error = 1
		    endi
		    dift d_good = 1
			  'get current operator
		        $cut s_operator, s_work, 1, 1
		    
		        $ift s_operator = "+"
				d_answer = d_answer + d_number
			  endi
		        $ift s_operator = "-"
				d_answer = d_answer - d_number
			  endi
		        $ift s_operator = "*"
				d_answer = d_answer * d_number
			  endi
		        $ift s_operator = "/"
				d_answer = d_answer / d_number
			  endi
		        $ift s_operator = "\"
				d_answer = d_answer \ d_number
			  endi
		        $ift s_operator = "^"
				dpow d_answer, d_answer, d_number
			  endi
		        $ift s_operator = "%"
				d_answer = d_answer % d_number
			  endi

			  'put next operator in 1
		        $cut s_work, s_work, d_byte, 99999
		        d_byte = 1
		    endi
	      endi

	      dinc d_byte

	      $len d_long, s_work
	      dift d_byte > d_long: dinc d_loop

	      dift d_error = 1: dinc d_loop

	      'we end with a semi-colon
	      $cut s_any, s_work, 1, 1
	      $ift s_any = ";": dinc d_loop
        endw

        dift d_error = 1
            s_out = "error in expression: " + s_line
		$inp s_any, s_out
		s_line = "X=X"
        else
		$cut s_any, s_line, 1, 1
		$ift s_any = "X": dg_xvalue = d_answer
		$ift s_any = "Y": dg_yvalue = d_answer
		$ift s_any = "Z": dg_zvalue = d_answer

		ded$ s_any, dg_xvalue, 0, 0
		s_out = "x=" + s_any
		ded$ s_any, dg_yvalue, 0, 0
		$app s_out, ", y=" + s_any
		ded$ s_any, dg_zvalue, 0, 0
		$app s_out, ", z=" + s_any

		'colon delimited into sg_xyzmath
		$app sg_xyzmath, s_out + ":"

		$app s_out, ", m=more"		

		$inp s_line, s_out
		$cup s_line, s_line
		$trb s_line, s_line

		'do we have x=, or y=
		d_process = 2
		$cut s_any, s_line, 1, 2
		$ift s_any = "X=": d_process = 1 
		$ift s_any = "Y=": d_process = 1
		$ift s_any = "Z=": d_process = 1

		$ift s_any = "M"
		    'print or list from sg_xyzmath colon delimited
		    $ch$ s_aster, "*", 60
		    s_line = "X=X"

		    $out s_aster
		    d_dot = 1
		    d_loop = 1
		    dwhi d_loop = 1
			  $par s_dot, sg_xyzmath, ":", d_dot
			  $trb s_dot, s_dot
			  $ift s_dot = sg_nothing
				dinc d_loop
			  else
				dinc d_lines
				dift d_lines > 40
				    d_lines = 1
				endi
				$out s_dot
				dinc d_dot
			  endi
		    endw
		    $out s_aster
		    d_process = 1
		endi
	  endi
	  s_command = "none"
    endw
    sg_pass1 = s_command
ends sub_xyzmath


subr sub_path_memory_lines
'updated 2007/11/12
'2006/09/25, 2006/09/04, 2006/08/29, 2006/04/23, 2005/10/08
    vari s_out, s_path, d_memory, s_memory
    vari d_lines, s_lines, s_date, s_version

    $sys s_version, 3
    $out s_version
    $out sg_build

    $sys s_path, 1
    $out "Path: " + s_path

    $dat s_date
    $cut s_date, s_date, 1, 20
    dsys d_memory, 1
    dsys d_lines, 2
    ded$ s_memory, d_memory, 0, 0
    ded$ s_lines, d_lines, 0, 0
    s_out = "memory=" + s_memory 
    $app s_out, ", lines=" + s_lines
    $app s_out, ", date=" + s_date
    $out s_out
ends sub_path_memory_lines


subr sub_speed2
'updated 2005/09/05, 2003/01/29
'speed of computer
    vari d_any, s_any, d_dot, s_dot
    vari d_time1, d_time2, d_count, d_seconds, s_which, d_best
    vari d_millions, d_total, s_aster
    vari d_testcount1, d_testcount2
    vari d_average1, d_average2, s_average

    $ch$ s_aster, "*", 76

    $inp s_any, "1 = one million times, 2 = two million times etc."
    $isd d_any, s_any
    dift d_any <> 1: s_any = "1"
    $tod d_millions, s_any
    d_total = d_millions * 10000 * 100

    $inp s_which, "1 = dinc loop, 2 = dinc loop repeat, 3 = dset"

    $out s_aster
    $out "We are looping " + d_millions + " millions of times"

    d_count = 0

    $ift s_which = "1"
	  'dinc loop
	  dsec d_time1
        dwhi d_count < d_total
	      dinc d_count
        endw
	  dsec d_time2

        $out s_aster
        d_seconds = d_time2 - d_time1
        $out d_seconds + ",  " + d_total
    endi

    $ift s_which = "2"
	  'repeat loop d_testcount2 number of times
	  d_testcount2 = 99999
	  $inp s_any, "how many repeats?"
	  $isd d_any, s_any
	  dift d_any = 1: $tod d_testcount2, s_any

	  d_testcount1 = 1

	  d_average1 = 0
	  d_average2 = 0
	  d_best = 99999

	  dwhi d_testcount1 <= d_testcount2
		d_count = 0
	      dsec d_time1
            dwhi d_count < d_total
	          dinc d_count
            endw
	      dsec d_time2

	      d_seconds = d_time2 - d_time1
		d_average1 = d_average1 + d_seconds
		d_average2 = d_average1 / d_testcount1
		dto$ s_average, d_average2, 5, 3

		dift d_seconds < d_best: d_best = d_seconds
		ded$ s_any, d_total, 0, 0
		dto$ s_dot, d_testcount1, 5, 0

            s_any = s_dot + ". " + d_seconds + ", " + s_any + ", best=" 
		$app s_any, d_best + ", ave=" + s_average
		$out s_any

		dinc d_testcount1
	  endw
    endi

    $ift s_which = "3"
	  dsec d_time1
        dwhi d_count < d_total
	      d_count = d_count + 1
        endw
	  dsec d_time2

        $out s_aster
        d_seconds = d_time2 - d_time1
        $out d_seconds + ",  " + d_total
    endi

    $ift s_which = "1"
        s_any = "dinc, seconds to loop " + d_millions    
	  $app s_any, " millions of times=" + d_seconds
	  $out s_any
    endi

    $ift s_which = "3"
        s_any = "dset, seconds to loop " + d_millions    
	  $app s_any, " millions of times=" + d_seconds
        $out s_any   
    endi

    $out s_aster

    $inp s_which, "return"
ends sub_speed2

subr sub_prime_speed_test
'updated 2006/08/27, 2006/08/26
'2006/03/03, 2005/12/11, 2005/10/08, 2004/02/15, 2004/02/14
'find the first 500,000 or 100,000 primes to test 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, d_tealines
    vari d_testprime, d_primetotal, d_lastprime

    dsys d_tealines, 2

    '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 = 99999
        $ift s_any = "1": d_action = 1
    endi
    dift d_action = 1
	  'use DFAC 500,000
        d_todocount = 500 * 1000
	  ded$ s_any, d_todocount, 0, 0
        $out "finding the first " + s_any + " primes"
    endi
    dift d_action = 2
	  'do not use DFAC 100,000
        d_todocount = 100 * 1000
	  ded$ s_any, d_todocount, 0, 0
        $out "finding the first " + s_any + " primes"
    endi

    dsec d_sec1
    d_primetotal = 1 + 2 + 3
    d_lastprime = 3

    '1,2,3 are presumed
    d_count = 3
    d_testprime = 5
    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_simple
	  dift dg_pass1 = 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 = 1
        $out "The above numbers should be as follows."
        $out "Prime total = 1,774,817,902,653"
        $out "Last prime = 7,368,743"
        $out "Primes count = 500,000"

        $out s_dash

        $out "The time was " + d_sec3 + " seconds."

        $out s_dash
    endi
    dift d_action = 2
        $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
       
    dsys d_any, 2
    d_tealines = d_any - d_tealines
    ded$ s_any, d_tealines, 0, 0
    $out "total lines=" + s_any

    $inp s_any, "return"
ends sub_prime_speed_test


subr sub_prime_test_simple
'updated 2006/08/27, 2006/08/26, 2006/08/04, 2005/02/14, 2005/02/13
'2005/02/09, 2005/02/06, 2005/01/30, 2004/11/27, 2003/04/11
'simple test dg_pass1 for prime, if prime set dg_pass1 to 1
'otherwise set dg_pass1 to the divisor
'return number of tealines in dg_pass2
    vari d_any, s_any, d_dot, s_dot
    vari d_number, d_try, d_root, d_mod
    vari d_loop, d_result

    'make positive whole number 
    d_number = dg_pass1 \ 1
    dabs d_number, d_number

    'get root of
    d_any = 1 / 2
    dpow d_root, d_number, d_any

    d_result = 1

    dift d_number > 3
        'first try 2
        d_mod = d_number % 2
        dift d_mod = 0: d_result = 2
    endi

    d_try = 3
    d_loop = d_result
    dift d_try > d_root: dinc d_loop

    dwhi d_loop = 1
	  'test d_try
	  d_mod = d_number % d_try

	  dift d_mod = 0
	      'd_number is not prime
	      dinc d_loop
	      d_result = d_try
	  else
	      d_try = d_try + 2
	      dift d_try > d_root: dinc d_loop
	  endi		
    endw

    dg_pass1 = d_result
ends sub_prime_test_simple

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

subr sub_speed_test
'updated 2008/01/10, 2007/11/12
'2007/11/04, 2007/09/15, 2007/07/11, 2007/04/16, 2007/04/11
'2005/11/30, 2005/11/20, 2005/03/31, 2005/02/26, 2004/12/03
'speed test
    vari d_any, s_any, d_dot, s_dot
    vari d_time, d_max, d_count, s_dashes

    $sys s_any, 2
    $out s_any

    $ch$ s_dashes, "-", 70

    '50 million dinc loop
    d_max = 10000 * 5000

    'dwhi loop
    $out s_dashes
    d_count = 0

    dsec d_time
    dwhi d_count < d_max
	  dinc d_count
    endw
    dsec d_any

    d_time = d_any - d_time
    ded$ s_any, d_count, 0, 0
    $out "loops=" + s_any
    $out "dwhi dinc loop, seconds=" + d_time 

    $out s_dashes
    sub_path_memory_lines

    $out s_dashes
    $inp s_any, "return"
ends sub_speed_test