############################################################################
#
#	File:     printf.icn
#
#	Subject:  Procedures for printf-style formatting
#
#	Author:   William H. Mitchell
#
#	Date:     March 18, 2021 
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	Contributors:   Cheyenne Wills, Phillip Lee Thomas,
#			Michael Glass, Gregg M. Townsend,
#			Clinton Jeffery
#
############################################################################
#
# This module provides a family of formatted output functions
# modeled on those found in the C language.
#
# printf(fmt:string, args[]) formats and writes arguments to &output.
# fprintf(f:file,fmt:string,args[]) formats and writes arguments to f.
# sprintf(fmt:string, args[]) : string formats arguments and returns a string.
#
# The format string fmt is modified by substituting arguments
# in place of the ``format specifiers'' within it, consisting of a
# percent sign followed by a specifier code.  Specifier codes include
#
# specifier     arg is printed the form of
# %d		decimal integer
# %e		scientific notation
# %i		image
# %o		octal
# %r		real number. Exponential format if number is larger than int
# %s		string
# %c		character. Like %s only it only prints first letter.
# %x		hexadecimal
#
# An hyphen after the percent sign indicates left justification,
# otherwise right justification is used. A number of digits after the
# percent sign may specify the width of the field to use, or after a
# period they specify a number of digits of precision. For example,
# printf("%-5.2r", x) specifies that real number x be
# formatted as a string of at least 5 characters, left justified,
# with two digits after the decimal point.
#
#     Code contributions for %f and %g formats that work like 
#  C's printf() would be welcome.
#
#     Possible new formats:
#
#	   %t -- print a real number as a time in hh:mm
#	   %R -- roman numerals
#	   %w -- integers in English
#	   %b -- binary
#
############################################################################

procedure sprintf(format, args[])
	return _doprnt(format, args)
end

procedure fprintf(file, format, args[])
	writes(file, _doprnt(format, args))
	return
end

procedure printf(format, args[])
	writes(&output, _doprnt(format, args))
	return
end

procedure _doprnt(format, args)
   local out, v, just, width, conv, prec, pad

	out := ""
	format ? repeat {
		(out ||:= tab(upto('%'))) | (out ||:= tab(0) & break)
		v := get(args)
		move(1)
		just := right
		width := conv := prec := pad := &null
		="-" & just := left
		width := tab(many(&digits))
		(\width)[1] == "0" & pad := "0"
		="." & prec := tab(many(&digits))
		conv := move(1)

		##write("just: ",image(just),", width: ", width, ", prec: ",
		## prec, ", conv: ", conv)
		case conv of {
		    "d": {
			v := string(integer(v))
			}
		    "s": {
			v := string(v[1:(\prec+1)|0])
			}
		    "c": { # treat %c as %s except it only prints first letter
			v := string(v[1:(\prec+1)|0])
			v := v[1]
			}
		    "x": v := hexstr(v)
		    "o": v := octstr(v)
		    "i": v := image(v)
		    "r": v := fixnum(v,prec)
		    "e": v := eformatstr(v, prec, width)
		    default: {
			push(args, v)
			v := conv
			}
		    }
		if \width & *v < width then {
			v := just(v, width, pad)
			}
		out ||:= v
		}

	return out
end

procedure hexstr(n)
   return _basestr(n, 4)
end

procedure octstr(n)
   return _basestr(n, 3)
end

procedure _basestr(n, b)
   local s, mask

	n := integer(n) | return image(n)

	if n = 0 then
		return "0"

	# backwards compatibility hack
	# treat 31-bit negative integers as positive values
	if -16r80000000 <= n <= -1 then
		n +:= 16r100000000

	s := ""
	mask := ishift(1, b) - 1
	while n ~= 0 & n ~= -1 do {
		s := "0123456789abcdef" [1 + iand(n, mask)] || s
		n := ishift(n, -b)
		}
	return s
end

procedure fixnum(x, prec)
   local s

	/prec := 6
	x := real(x) | return image(x)

	if x < 0 then {
	   s := "-"
	   x := -x
	   }
	else
	   s := ""

	x := string(integer(x * 10 ^ prec + 0.5))
	if *x <= prec then
	   x := right(x, prec + 1, "0")
	return s || x[1:-prec] || "." || x[-prec:0]
end


# e-format:  [-]m.dddddde(+|-)xx
#
# Differs from C and Fortran E formats primarily in the
# details, among them:
#
# - Single-digit exponents are not padded out to two digits.
#
# - The precision (number of digits after the decimal point)
#   is reduced if needed to make the number fit in the available
#   width, if possible.  The precision is never reduced-to-fit
#   below 1 digit after the decimal point.
#
procedure eformatstr(x, prec, width)
   local signpart, wholepart, fracpart, exppart
   local choppart, shiftcount, toowide
   local rslt, s

   /prec := 6
   /width := prec + 7

   # Separate string representation of x into parts
   #
   s := string(real(x)) | return image(x)
   s ? {
      signpart  :=  (=("-" | "+") | "")
      wholepart :=  1(tab(many(&digits)), any('.eE')) | return image(x) 
      fracpart  :=  ((=".", tab(many(&digits)))  | "")
      exppart   :=  integer((=("e"|"E"), tab(0))  | 0)
      }

   # When the integer part has more than 1 digit, shift it
   #  right into fractional part and scale the exponent
   #
   if *wholepart > 1 then {
      exppart +:= *wholepart -1
      fracpart := wholepart[2:0] || fracpart
      wholepart := wholepart[1]
      }

   # If the the number is unnormalized, shift the fraction
   #   left into the whole part and scale the exponent
   #
   if wholepart == "0" then {
      if shiftcount := upto('123456789', fracpart) then {
         exppart -:= shiftcount
         wholepart := fracpart[shiftcount] 
         fracpart := fracpart[shiftcount+1:0]
         }
      }

   # Adjust the fractional part to the requested precision.
   # If the carry causes the whole part to overflow from
   #    9 to 10 then renormalize.
   #
   fracpart := adjustfracprec(fracpart, prec)
   wholepart +:= fracpart[2]
   fracpart := fracpart[1]
   if *wholepart > 1 then {
      wholepart := wholepart[1]
      exppart +:= 1
      }

   #  Assemble the final result.
   #  - Leading "+" dropped in mantissa
   #  - Leading "+" obligatory in exponent
   #  - Decimal "." included iff fractional part is non-empty
   #
   wholepart := (signpart == "-", "-") || wholepart
   exppart  :=  (exppart > 0, "+")   || exppart
   fracpart :=  (*fracpart > 0, ".") || fracpart
   rslt     := wholepart || fracpart || "e" || exppart

   # Return the result.  
   # -- If too short, pad on the left with blanks (not zeros!).
   # -- If too long try to shrink the precision 
   # -- If shrinking is not possible return a field of stars.
   #
   return (*rslt <= width,        right(rslt, width)) |  
          (*rslt - width < prec,  eformatstr(x, prec + width - *rslt, width)) |
          repl("*", width)
end

#  Zero-extend or round the fractional part to 'prec' digits.
#
#  Returns a list: 
#
#     [ fracpart, carry ]
#
#  where the fracpart has been adjusted to the requested
#  precision, and the carry (result of possible rounding)
#  is to be added into the whole number.
#
procedure adjustfracprec(fracpart, prec)

   local choppart, carryout

   #  Zero-extend if needed.
   if *fracpart < prec then return [left(fracpart, prec, "0"), 0]

   # When the fractional part has more digits than the requested 
   #   precision, chop off the extras and round.
   #
   carryout := 0
   if *fracpart > prec then {
      choppart := fracpart[prec+1:0]
      fracpart := fracpart[1+:prec]

      # If rounding up is needed...
      #
      if choppart[1] >>= "5" then {

         #  When the fractional part is .999s or the precision is 0,
         #     then round up overflows into the whole part.
         #
         if (prec = 0) | (string(cset(fracpart)) == "9") then {
            fracpart := left("0", prec, "0")
            carryout := 1
            }
         #  In the usual case, round up simply increments the
         #     fractional part.  (We put back any leading
         #     zeros that got lost.) 
         else {
            fracpart := right(integer(fracpart)+1, prec, "0")
            }
         }
      }
   return [fracpart, carryout]
end