############################################################################
#
#	File:     numbers.icn
#
#	Subject:  Procedures related to numbers
#
#	Author:   Ralph E. Griswold
#
#	Date:     June 10, 2001
#
#	Modified: Bruce Rennie
#
#	Date:     August 13, 2020
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	Contributors:  Robert J. Alexander, Richard Goerwitz
#	   Tim Korb, and Gregg M. Townsend
#
#       May 08, 2019: add mfloor() and mceil() functions
#       Nov 15, 2019: add thread-safe large() function
#
#       Aug 13, 2020: fix thread-safe large() function to return parameter
#
############################################################################
#
#	These procedures deal with numbers in various ways:
#
#	adp(i)		additive digital persistence of i
#
#	adr(i)		additive digital root of i (same as digred())
#
#	amean ! L	returns arithmetic mean of numbers in L.
#
#	ceil(r)		returns nearest integer to r away from 0.
#
#	mceil(r)	returns the least integer greater than or equal to r.
#
#	commas(s)	inserts commas in s to separate digits into groups of
#			three.
#
#	decimal(i, j)	decimal expansion of i / j; terminates when expansion
#			terminates or the end of a recurring period is reached.
#			The format of the returned value is <integer>.<seq>,
#			where <seq> is a string a decimal digits if the
#			expansion is finite but <pre>[<recurr>] if it
#			is not, where <pre> is a string of decimal digits
#			(possibly empty) before the recurring part.
#
#	decipos(r, i, j)
#			positions decimal point at i in real number r in
#			field of width j.
#
#	digprod(i)	product of digits of i
#
#	digred(i)	reduction of number by adding digits until one digit is
#			reached.
#
#	digroot(i)	same as digred().
#
#	digsum(i)	sum of digits in i.
#
#	distseq(i, j)	generates i to j in distributed order.
#
#	div(i, j)	produces the result of real division of i by j.
#
#	fix(i, j, w, d)	formats i / j as a real (floating-point) number in
#			a field of width w with d digits to the right of
#			the decimal point, if possible. j defaults to 1,
#			w to 8, and d to 3. If w is less than 3 it is set
#			to 3. If d is less than 1, it is set to 1. The
#			function fails if j is 0 or if the number cannot
#			be formatted.
#
# 	floor(r)	nearest integer to r toward 0.
#
# 	mfloor(r)	returns the greatest integer less than or equal to r.
#
#	frn(r, w, d)    format real number r into a string with d digits
#			after the decimal point; a result narrower than w
#			characters is padded on the left with spaces.
#			Fixed format is always used; there is no exponential
#			notation.  Defaults:  w 0, d  0
#
#	gcd(i, j)	returns greatest common divisor of i and j.
#
#	gcdl ! L	returns the greatest common division of the integers
#			list L.
#
#	gmean ! L	returns geometric mean of numbers in L.
#
#	hmean ! L	returns harmonic mean of numbers in L.
#
#	large(i)	succeeds if i is a large integer but fails otherwise.
#
#	lcm(i, j)	returns the least common multiple of i and j.
#
#	lcml ! L	returns the least common multiple of the integers
#			in the list L.
#
#	mantissa(r)	mantissa (fractional part) of r.
#
#	max ! L		produces maximum of numbers in L.
#
#	mdp(i)		multiplicative digital persistence of i
#
#	mdr(i)		multiplicative digital root of i
#
#	min ! L		produces minimum of numbers in L.
#
#	mod1(i, m)	residue for 1-based indexing.
#
#	npalins(n)	generates palindromic n-digit numbers.
#
#	residue(i, m, j)
#			residue for j-based indexing.
#
#	roman(i)	converts i to Roman numerals.
#
#	round(r)	returns nearest integer to r.
#
#	sigma(i)	synonym for digroot(i)
#
#	sign(r)		returns sign of r.
#
#	spell(i)	spells out i in English.
#
#	sum ! L		sum of numbers in list L
#
#	trunc(r)	returns nearest integer to r toward 0
#
#	unroman(s)	converts Roman numerals to integers.
#
############################################################################
#
#	Links:  factors, strings
#
############################################################################

link factors
link strings

procedure adp(i)		#: additive digital persistence
   local j

   j := 0

   until *i = 1 do {
      i := digsum(i)
      j +:= 1
      }

   return j

end

procedure adr(i)		#: additive digital root

   until *i = 1 do
      i := digsum(i)

   return i

end

procedure amean(L[])		#: arithmetic mean
   local m

   if *L = 0 then fail

   m := 0.0
   every m +:= !L

   return m / *L

end

procedure ceil(r)		#: ceiling

   if integer(r) = r then return integer(r)

   if r > 0 then return integer(r) + 1 else return -(integer(-r) + 1)

end

procedure mceil(r)		#: mceiling

   if integer(r) = r then return integer(r)

   if r > 0 then return integer(r) + 1 else return -integer(-r)

end

procedure commas(s)		#: insert commas in number

   local s2, sign

   # Don't bother if s is already comma-ized.
   if type(s) == "string" & find(",",  s) then fail

   # Take sign.  Save chars after the decimal point (if present).
   if s := abs(0 > s)
   then sign := "-" else sign := ""
   s ? {
      s := tab(find(".")) & ="." &
      not pos(0) & s2 := "." || tab(0)
      }

   /s2 := ""
   integer(s) ? {
      tab(0)
      while s2 := "," || move(-3) || s2
      if pos(1)
      then s2 ?:= (move(1), tab(0))
      else s2 := tab(1) || s2
      }

   return sign || s2

end

procedure decimal(i, j)		#: decimal expansion of rational
   local head, tail, numers, count

   head := (i / j) || "."
   tail := ""
   numers := table()

   i %:= j
   count := 0

   while i > 0 do {
      numers[i] := count
      i *:= 10
      tail ||:= i / j
      i %:= j
      if \numers[i] then	# been here; done that
	 return head || (tail ? (move(numers[i]) || "[" || tab(0) || "]"))
      count +:= 1
      }

   return head || tail

end

procedure decipos(r, i, j)	#: position decimal point
   local head, tail

   /i := 3
   /j := 5

   r := real(r) | stop("*** non-numeric in decipos()")

   if i < 1 then fail

   r ? {
      head := tab(upto('.eE')) | fail
      move(1)
      tail := tab(0)
      return left(right(head, i - 1) || "." || tail, j)
      }

end

procedure digred(i)		#: sum digits of integer repeated to one digit

   digred := digroot

   return digred(i)

end

procedure digroot(i)		#: digital root

   if i = 0 then return 1

   i %:= 9

   return if i = 0 then 9 else i

end

procedure digprod(i)		#: product of digits
   local j

   if upto('0', i) then return 0

   else j := 1

   every j *:= !string(i)

   return j

end

procedure digsum(i)		#: sum of digits
   local j

   i := integer(i) | fail

   repeat {
      j := 0
      every j +:= !string(i)
      suspend j
      if *j > 1 then i := j else fail
      }

end

#  distseq() generates a range of integers in a deterministic order that is
#  "most uniformly distributed" in Knuth's terminology (vol3, 1/e, p. 511).
#  Each integer in the range is produced exactly once.

procedure distseq(low, high)		#: generate low to high nonsequentially
   local n, start, incr, range

   low := integer(low) | runerr(101, low)
   high := integer(high) | runerr(101, high)
   if low > high then fail
   range := high - low + 1
   start := n := range / 2

   suspend low + n

   incr := integer(range / &phi ^ 2 + 0.5)
   if incr <= 1 then
      incr := 1
   else while gcd(incr, range) > 1 do
      incr +:= 1

   repeat {
      n := (n + incr) % range
      if n = start then fail
      suspend low + n
      }

end

procedure div(i, j)		#: real division

   return i / real(j)

end

procedure fix(i, j, w, d)	#: format real number
   local r, int, dec, sign

   /j := 1
   /w := 8
   /d := 3
   if j = 0 then fail
   w <:= 3
   d <:= 1
   r := real(i) / j
   if r < 0 then {
      r  := -r
      sign := "-"
      }
   else sign:=""

   int := dec := "0"  # prepare for small number

   if not(r < ("0." || repl("0", d - 1) || "1")) then { # formats as zero
      string(r) ? {
         if upto('eE') then fail # can't format
         if int := tab(find(".")) then {
            move(1)
            dec := tab(0)
            }
         }
      }

   return right(sign || int || "." || left(dec, d, "0"), w)
end

procedure floor(r)		#: floor

   if r > 0 then return integer(r) else return -integer(-r)

end

procedure mfloor(r)		#: mfloor
   if integer(r) = r then return integer(r)

   if r > 0 then return integer(r) else return -(integer(-r) + 1)

end

$define MAXDECIMALS 25

procedure frn(r, w, d)		#: format real number

   local s
   static mlist
   initial every put(mlist := list(), 10.0 ^ (0 to MAXDECIMALS))

   r := real(r) | runerr(102, r)
   (/d := 0) | (d >:= MAXDECIMALS)
   if r >= 0.0 then {
      s := string(integer(r * mlist[d + 1] + 0.5))
      s := right(s, *s < d + 1, "0")
      }
   else {
      s := string(integer(-r * mlist[d + 1] + 0.5))
      s := right(s, *s < d + 1, "0")
      s := "-" || s
      }
   s := right(s, *s < (\w - 1))

   return s ? (tab(-d) || "." || tab(0))

end

procedure gcd(i,j)		#: greatest common divisor
   local r

   i := (0 < i) | -i
   j := (0 < j) | -j
   if j = 0 then if i ~= 0 then return i else runerr(501)
   if i = 0 then if j ~= 0 then return j else runerr(501)

   repeat {
      r := i % j
      if r = 0 then return j
      i := j
      j := r
      }
end

procedure gcdl(L[])		#: greatest common divisor of list
   local i, j

   i := get(L) | fail

   while j := get(L) do
      i := gcd(i, j)

   return i

end

procedure gmean(L[])		#: geometric mean
   local m

   if *L = 0 then fail

   m := 1.0
   every m *:= !L
   m := abs(m)
   if m > 0.0 then
      return exp (log(m) / *L)
   else
      fail
end

procedure hmean(L[])		#: harmonic mean
   local m, r

   if *L = 0 then fail

   m := 0.0

   every r := !L do {
      if r = 0.0 then fail
      else m +:= 1.0 / r
      }

   return *L / m

end

$ifndef _CONCURRENT
#
#  At the source-language level, "native" integers and "large"
#  integers have the same type, "integer".  The creation of a large
#  integer causes storage allocation, which this procedure detects.
#

procedure large(i)		#: detect large integers
   local mem

   mem := &allocated
   i +:= 0
   if &allocated > mem then return i
   else fail

end

$else

#
# The procedure above isn't thread safe because, if another thread
# makes a storage allocation between the two uses of &allocate,
# it might report that a small integer is a large integer.
#
# Updated return value on success to return the value supplied as per
# the procedure large() above.
#
procedure large(i)		#: detect large integers
   static m,e
   initial { m := mutex(); e := -1 }

   if type(i) == "integer" then {
      lock(m); &error :=: e
      if seq(i) then {
         &error :=: e; unlock(m); fail
      } else { # seq() failed, so i must be a large integer
         &error :=: e; unlock(m); return i		# Success
      }
   }
end

$endif							# _CONCURRENT

procedure lcm(i, j)		#: least common multiple

   if (i =  0) | (j = 0) then return 0	# ???

   return abs(i * j) / gcd(i, j)

end

procedure lcml(L[])		#: least common multiple of list
   local i, j

   i := get(L) | fail

   while j := get(L) do
      i := lcm(i, j)

   return i

end

procedure mantissa(r)		#: mantissa (fractional part)
   local fpart

   r := real(r)

   fpart := r - floor(r)

   fpart ?:= {
      tab(upto('.') + 1)
      tab(0)
      }

   fpart ? {
      if fpart := tab(upto('Ee')) then {
         move(1)
         if = "+" then fpart := "0"
         else {
            move(1)
            fpart := repl("0", tab(0) - 1) || fpart
            }
         }
      }

   return "." || fpart

end


# procedure max() removed due to its promotion to built-in function in Unicon


procedure mdp(i)		#: multiplicative digital persistence
   local j

   j := 0

   until *i = 1 do {
      i := digprod(i)
      j +:= 1
      }

   return j

end

procedure mdr(i)		#: multiplicative digital root

   until *i = 1 do
      i := digprod(i)

   return i

end


# procedure min() removed due to its promotion to built-in function in Unicon


procedure mod1(i, m)		#: modulus for 1-based integers

   i %:= m

   if i < 1 then i +:= m

   return i

end

procedure npalins(n)		#: palindromic numbers
   local i

   every i := palins(&digits, n) do
      if i[1] ~== "0" then suspend i	# can't start with zero

end

procedure residue(i, m, j)		#: residue for j-based integers

   /j := 0

   i %:= m

   if i < j then i +:= m

   return i

end

#  This procedure is based on a SNOBOL4 function written by Jim Gimpel.
#
procedure roman(n)		#: convert integer to Roman numeral
   local arabic, result
   static equiv

   initial equiv := ["","I","II","III","IV","V","VI","VII","VIII","IX"]

   integer(n) > 0 | fail
   result := ""
   every arabic := !string(n) do
      result := map(result,"IVXLCDM","XLCDM**") || equiv[arabic + 1]
   if find("*",result) then fail else return result

end

procedure round(r)		#: round real

   if r > 0 then return integer(r + 0.5) else return -integer(0.5 - r)

end

procedure sigma(i)		#: synonym for digroot()

   sigma := digroot

   return sigma(i)

end

procedure sign(r)		#: sign

   if r = 0 then return 0
   else if r < 0 then return -1
   else return 1

end

procedure spell(n)		#: spell out integer
   local m

   n := integer(n) | stop(image(n)," is not an integer")
   if n <= 12 then return {
      "0zero,1one,2two,3three,4four,5five,6six,7seven,8eight,_
         9nine,10ten,11eleven,12twelve," ? {
            tab(find(n))
            move(*n)
            tab(find(","))
            }
      }
   else if n <= 19 then return {
      spell(n[2] || "0") ?
         (if ="for" then "four" else tab(find("ty"))) || "teen"
      }
   else if n <= 99 then return {
      "2twen,3thir,4for,5fif,6six,7seven,8eigh,9nine," ? {
         tab(find(n[1]))
         move(1)
         tab(find(",")) || "ty" ||
            (if n[2] ~= 0 then "-" || spell(n[2]) else "")
         }
      }
   else if n <= 999 then return {
      spell(n[1]) || " hundred" ||
         (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "")
      }
   else if n <= 999999 then return {
      spell(n[1:-3]) || " thousand" ||
         (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "")
      }
   else if n <= 999999999 then return {
      spell(n[1:-6]) || " million" ||
         (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "")
      }
   else fail

end

procedure sum(values[])		#: sum of numbers
   local result

   result := 0

   every result +:= !values

   return result

end

procedure trunc(r)		#: truncate real

   return integer(r)

end

procedure unroman(s)		#: convert Roman numeral to integer
   local nbr,lastVal,val

   nbr := lastVal := 0

   s ? {
      while val := case map(move(1)) of {
	 "m": 1000
	 "d": 500
	 "c": 100
	 "l": 50
	 "x": 10
	 "v": 5
	 "i": 1
	 } do {
	 nbr +:= if val <= lastVal then val else val - 2 * lastVal
	 lastVal := val
	 }
      }
   return nbr

end
