############################################################################
#
# File: numbers.icn
#
# Subject: Procedures related to numbers
#
# Author: Ralph E. Griswold
#
# Date: July 14, 1998
#
############################################################################
#
# This file is in the public domain.
#
############################################################################
#
# Contributors: Robert J. Alexander, Richard Goerwitz
# Tim Korb, and Gregg M. Townsend
#
############################################################################
#
# These procedures format numbers in various ways:
#
# amean(L) returns arithmetic mean of numbers in L.
#
# ceil(r) returns nearest integer to r away from 0.
#
# commas(s) inserts commas in s to separate digits into groups of
# three.
#
# decipos(r, i, j)
# positions decimal point at i in real number r in
# field of width j.
#
# digred(i) reduction of number by adding digits until one digit is
# reached.
#
# 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
#
# 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. It fails
# if both are zero.
#
# 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.
#
# max(L) produces maximum of numbers in L.
#
# min(L) produces minimum of numbers in L.
#
# npalins(n) generates palindomic n-digit numbers.
#
# roman(i) converts i to Roman numerals.
#
# round(r) returns nearest integer to r.
#
# sign(r) returns sign of r.
#
# spell(i) spells out i in English.
#
# trunc(r) returns nearest integer less than r.
#
# unroman(s) converts Roman numerals to integers.
#
############################################################################
#
# Links: strings
#
############################################################################
link strings
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 commas(s) #: 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 := "." || integer(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 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
local j
until *i = 1 do {
j := 0
every j +:= !i
i := j
}
return i
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
/j := 1
/w := 8
/d := 3
if j = 0 then fail
w <:= 3
d <:= 1
r := real(i) / j
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(int || "." || left(dec, d, "0"), w)
end
procedure floor(r) #: floor
if r > 0 then return integer(r) else return -integer(-r)
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
if i = j = 0 then fail
if i = 0 then return j
if j = 0 then return i
i := abs(i)
j := abs(j)
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
#
# 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
procedure lcm(i, j) #: least common multiple
if i = j = 0 then fail
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 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
# 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 := !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 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 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
procedure min(values[]) #: minimum value
local minimum
minimum := get(values) | fail
every minimum >:= !values
return minimum
end
procedure max(values[]) #: maximum value
local maximum
maximum := get(values) | fail
every maximum <:= !values
return maximum
end