############################################################################
#
# 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
This page produced by UniDoc on 2021/04/15 @ 23:59:43.