-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


--% Description of Messages

--% OpenAxiom messages are read from a flat file database and returned
--% as one long string.  They are preceded in the database by a key and
--% this is how they are referenced from code.  For example, one key is
--% S2IL0001 which means:
--%    S2          Scratchpad II designation
--%    I           from the interpreter
--%    L           originally from LISPLIB BOOT
--%    0001        a sequence number

--% Each message may contain formatting codes and and parameter codes.
--% The formatting codes are:
--%    %b          turn on bright printing
--%    %ceoff      turn off centering
--%    %ceon       turn on centering
--%    %d          turn off bright printing
--%    %f          user defined printing
--%    %i          start indentation of 3 more spaces
--%    %l          start a new line
--%    %m          math-print an expression
--%    %rjoff      turn off right justification (actually ragged left)
--%    %rjon       turn on right justification (actually ragged left)
--%    %s          pretty-print as an S-expression
--%    %u          unindent 3 spaces
--%    %x#         insert # spaces

--% The parameter codes look like %1, %2b, %3p, %4m, %5bp, %6s where the
--% digit is the parameter number ans the letters following indicate
--% additional formatting. You can indicate as many additional formatting
--% qualifiers as you like, to the degree they make sense. The "p" code
--% means to call prefix2String on the parameter, a standard way of
--% printing abbreviated types.  The "P" operator maps prefix2String over 
--% its arguments.  The "o" operation formats the argument as an operation 
--% name.  "b" means to print that parameter in
--% a bold (bright) font. "c" means to center that parameter on a
--% new line.  "f" means that the parameter is a list [fn, :args]
--% and that "fn" is to be called on "args" to get the text. "r" means
--% to right justify (ragged left) the argument.

--% Look in the file with the name defined in $defaultMsgDatabaseName
--% above for examples.


import '"g-util"
)package "BOOT"

--% Message Database Code and Message Utility Functions

$msgDatabase := NIL
$cacheMessages := 'T  -- for debugging purposes
$msgAlist := NIL
$msgDatabaseName := NIL
$testingErrorPrefix :=  '"Daly Bug"
$testingSystem := false


$texFormatting := false

--% Accessing the Database

string2Words l ==
  i := 0
  [w while wordFrom(l,i) is [w,i]]

wordFrom(l,i) ==
  maxIndex := MAXINDEX l
  k := or/[j for j in i..maxIndex | l.j ^= char ('_ ) ] or return nil
  buf := '""
  while k < maxIndex and (c := l.k) ^= char ('_ ) repeat
    ch :=
      c = char '__   => l.(k := 1+k)  --this may exceed bounds
      c
    buf := STRCONC(buf,ch)
    k := k + 1
  if k = maxIndex and (c := l.k) ^= char ('_ ) then buf := STRCONC(buf,c)
  [buf,k+1]

getKeyedMsg key == fetchKeyedMsg(key,false)

--% Formatting and Printing Keyed Messages

segmentKeyedMsg(msg) == string2Words msg

segmentedMsgPreprocess x ==
  ATOM x => x
  [head,:tail] := x
  center := rightJust := NIL
  if head in '(%ceon "%ceon") then center := true
  if head in '(%rjon "%rjon") then rightJust := true
  center or rightJust =>
    -- start collecting terms
    y := NIL
    ok := true
    while tail and ok repeat
      [t,:tail] := tail
      t in '(%ceoff "%ceoff" %rjoff "%rjoff") => ok := NIL
      y := CONS(segmentedMsgPreprocess t,y)
    head1 := [(center => '"%ce"; '"%rj"),:NREVERSE y]
    NULL tail => [head1]
    [head1,:segmentedMsgPreprocess tail]
  head1 := segmentedMsgPreprocess head
  tail1 := segmentedMsgPreprocess tail
  EQ(head,head1) and EQ(tail,tail1) => x
  [head1,:tail1]

removeAttributes msg ==
    --takes a segmented message and returns it with the attributes
    --separted.
    first msg ^= '"%atbeg" =>
        [msg,NIL]
    attList := []
    until item = '"%atend" repeat
        msg     := rest  msg
        item    := first msg
        attList := [INTERN item,:attList]
    msg := rest msg
    attList := rest attList
    [msg,attList]

substituteSegmentedMsg(msg,args) ==
  -- this does substitution of the parameters
  l := NIL
  nargs := #args
  for x in segmentedMsgPreprocess msg repeat
    -- x is a list
    PAIRP x =>
      l := cons(substituteSegmentedMsg(x,args),l)
    c := x.0
    n := STRINGLENGTH x

    -- x is a special case
    (n > 2) and (c = "%") and (x.1 = "k") =>
        l := NCONC(NREVERSE pkey SUBSTRING(x,2,NIL),l)

    -- ?name gets replaced by '"Push PF10" or '"Type >b (enter)"
    (x.0 = char "?") and n > 1 and (v := pushOrTypeFuture(INTERN x,nil)) =>
      l := NCONC(NREVERSE v,l)

    -- x requires parameter substitution
    (x.0 = char "%") and (n > 1) and (DIGITP x.1) =>
      a := DIG2FIX x.1
      arg :=
        a <= nargs => args.(a-1)
        '"???"
      -- now pull out qualifiers
      q := NIL
      for i in 2..(n-1) repeat q := cons(x.i,q)
      -- Note 'f processing must come first.
      if MEMQ(char 'f,q) then
          arg :=
              PAIRP arg => APPLY(first arg, rest arg)
              arg
      if MEMQ(char 'm,q) then arg := [['"%m",:arg]]
      if MEMQ(char 's,q) then arg := [['"%s",:arg]]
      if MEMQ(char 'p,q) then 
          $texFormatting => arg := prefix2StringAsTeX arg
          arg := prefix2String arg 
      if MEMQ(char 'P,q) then
          $texFormatting => arg := [prefix2StringAsTeX x for x in arg]
          arg := [prefix2String x for x in arg]
      if MEMQ(char 'o, q) and $texFormatting then arg := operationLink(arg)

      if MEMQ(char 'c,q) then arg := [['"%ce",:arg]]
      if MEMQ(char 'r,q) then arg := [['"%rj",:arg]]

      if MEMQ(char 'l,q) then l := cons('"%l",l)
      if MEMQ(char 'b,q) then l := cons('"%b",l)
      --we splice in arguments that are lists
      --if y is not specified, then the adding of blanks is
      --stifled after the first item in the list until the
      --end of the list. (using %n and %y)
      l :=
         PAIRP(arg) =>
           MEMQ(char 'y,q) or (CAR arg = '"%y") or ((LENGTH arg) = 1)  =>
             APPEND(REVERSE arg, l)
           head := first arg
           tail := rest arg
           ['"%y",:APPEND(REVERSE tail, ['"%n",head,:l ]) ]
         cons(arg,l)
      if MEMQ(char 'b,q) then l := cons('"%d",l)
      for ch in '(_. _, _! _: _; _?) repeat
        if MEMQ(char ch,q) then l := cons(ch,l)

    --x is a plain word
    l := cons(x,l)
  addBlanks NREVERSE l

addBlanks msg ==
  -- adds proper blanks
  null PAIRP msg => msg
  null msg => msg
  LENGTH msg = 1 => msg
  blanksOff := false
  x := first msg
  if x = '"%n" then
    blanksOff := true
    msg1 := []
  else
    msg1 := LIST x
  blank := '" "
  for y in rest msg repeat
    y in '("%n" %n) => blanksOff := true
    y in '("%y" %y) => blanksOff  := false
    if noBlankAfterP x or noBlankBeforeP y or blanksOff then
       msg1 := [y,:msg1]
    else
       msg1 := [y,blank,:msg1]
    x := y
  NREVERSE msg1


SETANDFILEQ($msgdbPrims,'( %b %d %l %i %u %U %n %x %ce %rj "%U" "%b" "%d" "%l" "%i" "%u" "%U" "%n" "%x" "%ce" "%rj"))
SETANDFILEQ($msgdbPunct,'(_. _, _! _: _; _? _] _)  "." "," "!" ":" ";" "?" "]" ")"  ))
SETANDFILEQ($msgdbNoBlanksBeforeGroup,['" ", " ", '"%", "%",_
                            :$msgdbPrims, :$msgdbPunct])
SETANDFILEQ($msgdbListPrims,'(%m %s %ce %rj "%m" "%s" "%ce" "%rj"))

noBlankBeforeP word==
    INTP word => false
    word in $msgdbNoBlanksBeforeGroup => true
    if CVECP word and SIZE word > 1 then
       word.0 = char '% and word.1 = char 'x => return true
       word.0 = char " " => return true
    (PAIRP word) and (CAR word in $msgdbListPrims) => true
    false

$msgdbPunct := '(_[ _(  "[" "(" )
SETANDFILEQ($msgdbNoBlanksAfterGroup,['" ", " ",'"%" ,"%",_
                          :$msgdbPrims,:$msgdbPunct])

noBlankAfterP word==
    INTP word => false
    word in $msgdbNoBlanksAfterGroup => true
    if CVECP word and (s := SIZE word) > 1 then
       word.0 = char '% and word.1 = char 'x => return true
       word.(s-1) = char " " => return true
    (PAIRP word) and (CAR word in $msgdbListPrims) => true
    false

cleanUpSegmentedMsg msg ==
  -- removes any junk like double blanks
  -- takes a reversed msg and puts it in the correct order
  null PAIRP msg => msg
  blanks := ['" "," "]
  haveBlank := NIL
  prims :=
    '(%b %d %l %i %u %m %ce %rj _
     "%b" "%d" "%l" "%i" "%m" "%u" "%ce" "%rj")
  msg1 := NIL
  for x in msg repeat
    if haveBlank and ((x in blanks) or (x in prims)) then
      msg1 := CDR msg1
    msg1 := cons(x,msg1)
    haveBlank := (x in blanks => true; NIL)
  msg1

operationLink name ==
  FORMAT(nil, '"\lispLink{\verb!(|oSearch| _"~a_")!}{~a}",
         name,
         escapeSpecialChars STRINGIMAGE name)

----------------------------------------
sayPatternMsg(msg,args) ==
  msg := segmentKeyedMsg msg
  msg := substituteSegmentedMsg(msg,args)
  sayMSG flowSegmentedMsg(msg,$LINELENGTH,3)

throwPatternMsg(key,args) ==
  sayMSG '" "
  if $testingSystem then sayMSG $testingErrorPrefix
  sayPatternMsg(key,args)
  spadThrow()

sayKeyedMsgAsTeX(key, args) == 
  $texFormatting: fluid := true
  sayKeyedMsgLocal(key, args)

sayKeyedMsg(key,args) ==
  $texFormatting: fluid := false
  sayKeyedMsgLocal(key, args)

sayKeyedMsgLocal(key, args) ==
  msg := segmentKeyedMsg getKeyedMsg key
  msg := substituteSegmentedMsg(msg,args)
  if $displayMsgNumber then msg := ['"%b",key,":",'"%d",:msg]
  msg' := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN)
  if $printMsgsToFile then sayMSG2File msg'
  sayMSG msg'

throwKeyedErrorMsg(kind,key,args) ==
  BUMPERRORCOUNT kind
  sayMSG '" "
  if $testingSystem then sayMSG $testingErrorPrefix
  sayKeyedMsg(key,args)
  spadThrow()

throwKeyedMsgSP(key,args,atree) ==
    if atree and (sp := getSrcPos(atree)) then
        sayMSG '" "
        srcPosDisplay(sp)
    throwKeyedMsg(key,args)

throwKeyedMsg(key,args) ==
  $saturn => saturnThrowKeyedMsg(key, args)
  throwKeyedMsg1(key, args)

saturnThrowKeyedMsg(key,args) ==
  SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream)
  last := pushSatOutput("line")
  sayString '"\bgroup\color{red}\begin{list}\item{} "
  sayKeyedMsgAsTeX(key,args)
  sayString '"\end{list}\egroup"
  popSatOutput(last)
  spadThrow()

throwKeyedMsg1(key,args) ==
  SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream)
  sayMSG '" "
  if $testingSystem then sayMSG $testingErrorPrefix
  sayKeyedMsg(key,args)
  spadThrow()

throwListOfKeyedMsgs(descKey,descArgs,l) ==
  -- idea is that descKey and descArgs are the message describing
  -- what the list is about and l is a list of [key,args] messages
  -- the messages in the list are numbered and should have a %1 as
  -- the first token in the message text.
  sayMSG '" "
  if $testingSystem then sayMSG $testingErrorPrefix
  sayKeyedMsg(descKey,descArgs)
  sayMSG '" "
  for [key,args] in l for i in 1.. repeat
    n := STRCONC(object2String i,'".")
    sayKeyedMsg(key,[n,:args])
  spadThrow()

--  breakKeyedMsg is like throwKeyedMsg except that the user is given
--  a chance to play around in a break loop if $BreakMode is not 'nobreak

breakKeyedMsg(key,args) ==
  BUMPERRORCOUNT "semantic"
  sayKeyedMsg(key,args)
  handleLispBreakLoop($BreakMode)

keyedSystemError(key,args) ==
  $saturn => saturnKeyedSystemError(key, args)
  keyedSystemError1(key, args)

saturnKeyedSystemError(key, args) ==
  SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream)
  sayString '"\bgroup\color{red}"
  sayString '"\begin{verbatim}"
  sayKeyedMsg("S2GE0000",NIL)
  BUMPERRORCOUNT "semantic"
  sayKeyedMsgAsTeX(key,args)
  sayString '"\end{verbatim}"
  sayString '"\egroup"
  handleLispBreakLoop($BreakMode)

keyedSystemError1(key,args) ==
  sayKeyedMsg("S2GE0000",NIL)
  breakKeyedMsg(key,args)

-- these 2 functions control the mode of saturn output.
-- having the stream writing functions control this would
-- be better (eg. sayText, sayCommands)

pushSatOutput(arg) ==
  $saturnMode = arg => arg
  was := $saturnMode
  arg = "verb" => 
    $saturnMode := "verb"
    sayString '"\begin{verbatim}"
    was
  arg = "line" =>
    $saturnMode := "line"
    sayString '"\end{verbatim}"
    was
  sayString FORMAT(nil, '"What is: ~a", $saturnMode)
  $saturnMode
 
popSatOutput(newmode) == 
  newmode = $saturnMode => nil
  newmode = "verb" => 
    $saturnMode := "verb"
    sayString '"\begin{verbatim}"
  newmode = "line" =>
    $saturnMode := "line"
    sayString '"\end{verbatim}"
  sayString FORMAT(nil, '"What is: ~a", $saturnMode)
  $saturnMode

systemErrorHere functionName ==
  keyedSystemError("S2GE0017",[functionName])

isKeyedMsgInDb(key,dbName) ==
  $msgDatabaseName : fluid := pathname dbName
  fetchKeyedMsg(key,true)

getKeyedMsgInDb(key,dbName) ==
  $msgDatabaseName : fluid := pathname dbName
  fetchKeyedMsg(key,false)

sayKeyedMsgFromDb(key,args,dbName) ==
  $msgDatabaseName : fluid := pathname dbName
  msg := segmentKeyedMsg getKeyedMsg key
  msg := substituteSegmentedMsg(msg,args)
  if $displayMsgNumber then msg := ['"%b",key,":",'%d,:msg]
--sayMSG flowSegmentedMsg(msg,$LINELENGTH,3)
  u := flowSegmentedMsg(msg,$LINELENGTH,3)
  sayBrightly u

returnStLFromKey(key,argL,:optDbN) ==
    savedDbN := $msgDatabaseName
    if IFCAR optDbN then
        $msgDatabaseName := pathname CAR optDbN
    text := fetchKeyedMsg(key, false)
    $msgDatabaseName := savedDbN
    text := segmentKeyedMsg text
    text := substituteSegmentedMsg(text,argL)

throwKeyedMsgFromDb(key,args,dbName) ==
  sayMSG '" "
  if $testingSystem then sayMSG $testingErrorPrefix
  sayKeyedMsgFromDb(key,args,dbName)
  spadThrow()

queryUserKeyedMsg(key,args) ==
  -- display message and return reply
  conStream := DEFIOSTREAM ('((DEVICE . CONSOLE) (MODE . INPUT)),120,0)
  sayKeyedMsg(key,args)
  ans := READ_-LINE conStream
  SHUT conStream
  ans

flowSegmentedMsg(msg, len, offset) ==
  -- tries to break a sayBrightly-type input msg into multiple
  -- lines, with offset and given length.
  -- msgs that are entirely centered or right justified are not flowed
  msg is [[ce,:.]] and ce in '(%ce "%ce" %rj "%rj") => msg

  -- if we are formatting latex, then we assume 
  -- that nothing needs to be done
  $texFormatting => msg
  -- msgs that are entirely centered are not flowed
  msg is [[ce,:.]] and ListMember?(ce,'(%ce "%ce")) => msg
 
  potentialMarg := 0
  actualMarg    := 0

  off := (offset <= 0 => '""; fillerSpaces(offset,'" "))
  off1:= (offset <= 1 => '""; fillerSpaces(offset-1,'" "))
  firstLine := true

  PAIRP msg =>
    lnl := offset
    if msg is [a,:.] and a in '(%b %d _  "%b" "%d" " ") then
      nl :=  [off1]
      lnl := lnl - 1
    else nl := [off]
    for f in msg repeat
      f in '("%l" %l) =>
        actualMarg := potentialMarg
        if lnl = 99999 then nl := ['%l,:nl]
        lnl := 99999
      PAIRP(f) and CAR(f) in '("%m" %m '%ce "%ce" %rj "%rj") =>
        actualMarg := potentialMarg
        nl := [f,'%l,:nl]
        lnl := 199999
      f in '("%i" %i ) =>
        potentialMarg := potentialMarg + 3
        nl := [f,:nl]
      PAIRP(f) and CAR(f) in '("%t" %t) =>
        potentialMarg := potentialMarg + CDR f
        nl := [f,:nl]
      sbl := sayBrightlyLength f
      tot := lnl + offset + sbl + actualMarg
      if firstLine then
        firstLine  := false
        offset := offset + offset
        off1   := STRCONC(off, off1)
        off    := STRCONC(off, off)
      if (tot <= len) or (sbl = 1 and tot = len) then
        nl := [f,:nl]
        lnl := lnl + sbl
      else
        f in '(%b %d _  "%b" "%d" " ") =>
          nl := [f,off1,'%l,:nl]
          actualMarg := potentialMarg
          lnl := -1 + offset + sbl
        nl := [f,off,'%l,:nl]
        lnl := offset + sbl
    concat nreverse nl
  concat('%l,off,msg)

--% Other handy things

keyedMsgCompFailure(key,args) ==
  -- Called when compilation fails in such a way that interpret-code
  --  mode might be of some use.
  not $useCoerceOrCroak =>   THROW('coerceOrCroaker, 'croaked)
  if not($Coerce) and  $reportInterpOnly then
    sayKeyedMsg(key,args)
    sayKeyedMsg("S2IB0009",NIL)
  null $compilingMap => THROW('loopCompiler,'tryInterpOnly)
  THROW('mapCompiler,'tryInterpOnly)

keyedMsgCompFailureSP(key,args,atree) ==
  -- Called when compilation fails in such a way that interpret-code
  --  mode might be of some use.
  not $useCoerceOrCroak =>   THROW('coerceOrCroaker, 'croaked)
  if not($Coerce) and  $reportInterpOnly then
    if atree and (sp := getSrcPos(atree)) then
        sayMSG '" "
        srcPosDisplay(sp)
    sayKeyedMsg(key,args)
    sayKeyedMsg("S2IB0009",NIL)
  null $compilingMap => THROW('loopCompiler,'tryInterpOnly)
  THROW('mapCompiler,'tryInterpOnly)

throwKeyedMsgCannotCoerceWithValue(val,t1,t2) ==
  null (val' := coerceInteractive(objNew(val,t1),$OutputForm)) =>
    throwKeyedMsg("S2IC0002",[t1,t2])
  val' := objValUnwrap(val')
  throwKeyedMsg("S2IC0003",[t1,t2,val'])

--% Some Standard Message Printing Functions

bright x == ['"%b",:(PAIRP(x) and NULL CDR LASTNODE x => x; [x]),'"%d"]
--bright x == ['%b,:(ATOM x => [x]; x),'%d]

mkMessage msg ==
  msg and (PAIRP msg) and ((first msg) in '(%l "%l"))  and
    ((last msg) in '(%l "%l")) => concat msg
  concat('%l,msg,'%l)

sayMessage msg == sayMSG mkMessage msg

sayNewLine(:margin) ==
  -- Note: this function should *always* be used by sayBrightly and
  -- friends rather than TERPRI --  see bindSayBrightly
  TERPRI()
  if margin is [n] then BLANKS n
  nil

sayString x ==
  -- Note: this function should *always* be used by sayBrightly and
  -- friends rather than PRINTEXP --  see bindSayBrightly
  PRINTEXP x

spadStartUpMsgs() ==
  -- messages displayed when the system starts up
  $LINELENGTH < 60 => NIL
  bar := fillerSpaces($LINELENGTH,specialChar 'hbar)
  sayKeyedMsg("S2GL0001",[_*BUILD_-VERSION_*, _*YEARWEEK_*])
  sayMSG bar
  sayKeyedMsg("S2GL0018C",NIL)
  sayKeyedMsg("S2GL0018D",NIL)
  sayKeyedMsg("S2GL0003B",[$opSysName])
  sayMSG bar
--  sayMSG bar
--  sayMSG '"                                    *"
--  sayMSG '"               *****    **     **  ***     ******    ** *     *"
--  sayMSG '"              *     *     *   *     *     *      *    ** ** ** **"
--  sayMSG '"                    *      * *      *    *        *   **  ***  **"
--  sayMSG '"               ******       *       *   *          *  *    *    *"
--  sayMSG '"              *     *      * *      *    *        *   *    *    *"
--  sayMSG '"              *     *     *   *     *     *      *    *    *    *"
--  sayMSG '"              *     *    *     *    *      *    *     *    *    *"
--  sayMSG '"               ***** * **       ** ***      ****     **   ***  ***"
--  sayMSG '"                                    *"
--  sayMSG '"   Issue )copyright for copyright notices."
--  sayKeyedMsg("S2GL0018A",NIL)
--  sayKeyedMsg("S2GL0018B",NIL)
--  sayKeyedMsg("S2GL0003C",NIL)
--  sayKeyedMsg("S2GL0003A",NIL)
--  if not $printTimeIfTrue then sayKeyedMsg("S2GL0004",NIL)
--  if not $printTypeIfTrue then sayKeyedMsg("S2GL0005",NIL)
  --  if not $displaySetValue then sayKeyedMsg("S2GL0007",NIL)
--  if not $HiFiAccess then sayKeyedMsg("S2GL0008",NIL)
--  sayMSG bar
--  version()
  $msgAlist := NIL    -- these msgs need not be saved
  sayMSG " "

HELP() == sayKeyedMsg("S2GL0019",NIL)

version() == _*YEARWEEK_*

--% Some Advanced Formatting Functions

brightPrint x ==
  $MARG : local := 0
  for y in x repeat brightPrint0 y
  NIL

brightPrint0 x ==
  $texFormatting => brightPrint0AsTeX x
  if IDENTP x then x := PNAME x

  -- if the first character is a backslash and the second is a percent sign,
  -- don't try to give the token any special interpretation. Just print
  -- it without the backslash.

  STRINGP x and STRINGLENGTH x > 1 and x.0 = char "\" and x.1 = char "%" =>
    sayString SUBSTRING(x,1,NIL)
  x = '"%l" =>
    sayNewLine()
    for i in 1..$MARG repeat sayString '" "
  x = '"%i" =>
    $MARG := $MARG + 3
  x = '"%u" =>
    $MARG := $MARG - 3
    if $MARG < 0 then $MARG := 0
  x = '"%U" =>
    $MARG := 0
  x = '"%" =>
    sayString '" "
  x = '"%%" =>
    sayString  '"%"
  x = '"%b" =>
    NULL IS_-CONSOLE CUROUTSTREAM => sayString '" "
    NULL $highlightAllowed        => sayString '" "
    sayString $highlightFontOn
  k := blankIndicator x => BLANKS k
  x = '"%d" =>
    NULL IS_-CONSOLE CUROUTSTREAM => sayString '" "
    NULL $highlightAllowed        => sayString '" "
    sayString $highlightFontOff
  STRINGP x => sayString x
  brightPrintHighlight x

brightPrint0AsTeX x == 
  x = '"%l" =>
    sayString('"\\")
    for i in 1..$MARG repeat sayString '"\ "
  x = '"%i" =>
    $MARG := $MARG + 3
  x = '"%u" =>
    $MARG := $MARG - 3
    if $MARG < 0 then $MARG := 0
  x = '"%U" =>
    $MARG := 0
  x = '"%" =>
    sayString '"\ "
  x = '"%%" =>
    sayString  '"%"
  x = '"%b" =>
    sayString '" {\tt "
  k := blankIndicator x => for i in 1..k repeat sayString '"\ "
  x = '"%d" =>
    sayString '"} "
  x = '"_"$_"" => 
    sayString('"_"\verb!$!_"")
  x = '"$" => 
    sayString('"\verb!$!")
  STRINGP x => sayString x
  brightPrintHighlight x

blankIndicator x ==
  if IDENTP x then x := PNAME x
  null STRINGP x or MAXINDEX x < 1 => nil
  x.0 = '% and x.1 = 'x =>
    MAXINDEX x > 1 => PARSE_-INTEGER SUBSTRING(x,2,nil)
    1
  nil

brightPrint1 x ==
  if x in '(%l "%l") then sayNewLine()
  else if STRINGP x then sayString x
       else brightPrintHighlight x
  NIL

brightPrintHighlight x ==
  $texFormatting => brightPrintHighlightAsTeX x
  IDENTP x =>
    pn := PNAME x
    sayString pn
  -- following line helps find certain bugs that slip through
  -- also see sayBrightlyLength1
  VECP x => sayString '"UNPRINTABLE"
  ATOM x => sayString object2String x
  [key,:rst] := x
  if IDENTP key then key:=PNAME key
  key = '"%m" => mathprint rst
  key in '("%p" "%s") => PRETTYPRIN0 rst
  key = '"%ce" => brightPrintCenter rst
  key = '"%rj" => brightPrintRightJustify rst
  key = '"%t"  => $MARG := $MARG + tabber rst
  sayString '"("
  brightPrint1 key
  if EQ(key,'TAGGEDreturn) then
    rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"]
  for y in rst repeat
    sayString '" "
    brightPrint1 y
  if rst and (la := LASTATOM rst) then
    sayString '" . "
    brightPrint1 la
  sayString '")"

brightPrintHighlightAsTeX x ==
  IDENTP x =>
    pn := PNAME x
    sayString pn
  ATOM x => sayString object2String x
  VECP x => sayString '"UNPRINTABLE"
  [key,:rst] := x
  key = '"%m" => mathprint rst
  key = '"%m" => rst
  key = '"%s" => 
    sayString '"\verb__"
    PRETTYPRIN0 rst
    sayString '"__"
  key = '"%ce" => brightPrintCenter rst
  key = '"%t"  => $MARG := $MARG + tabber rst
  -- unhandled junk (print verbatim(ish)
  sayString '"("
  brightPrint1 key
  if EQ(key,'TAGGEDreturn) then
    rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"]
  for y in rst repeat
    sayString '" "
    brightPrint1 y
  if rst and (la := LASTATOM rst) then
    sayString '" . "
    brightPrint1 la
  sayString '")"

tabber num ==
    maxTab := 50
    num > maxTab => maxTab
    num

brightPrintCenter x ==
  $texFormatting => brightPrintCenterAsTeX x
  -- centers rst within $LINELENGTH, checking for %l's
  ATOM x =>
    x := object2String x
    wid := STRINGLENGTH x
    if wid < $LINELENGTH then
      f := DIVIDE($LINELENGTH - wid,2)
      x := LIST(fillerSpaces(f.0,'" "),x)
    for y in x repeat brightPrint0 y
    NIL
  y := NIL
  ok := true
  while x and ok repeat
    if CAR(x) in '(%l "%l") then ok := NIL
    else y := cons(CAR x, y)
    x := CDR x
  y := NREVERSE y
  wid := sayBrightlyLength y
  if wid < $LINELENGTH then
    f := DIVIDE($LINELENGTH - wid,2)
    y := CONS(fillerSpaces(f.0,'" "),y)
  for z in y repeat brightPrint0 z
  if x then
    sayNewLine()
    brightPrintCenter x
  NIL

brightPrintCenterAsTeX x ==
  ATOM x =>
    sayString '"\centerline{"
    sayString x
    sayString '"}"
  lst := x
  while lst repeat 
    words := nil
    while lst and not CAR(lst) = "%l" repeat
      words := [CAR lst,: words]
      lst := CDR lst
    if lst then lst := cdr lst
    sayString '"\centerline{"
    words := nreverse words
    for zz in words repeat
      brightPrint0 zz
    sayString '"}"
  nil 

brightPrintRightJustify x ==
  -- right justifies rst within $LINELENGTH, checking for %l's
  ATOM x =>
    x := object2String x
    wid := STRINGLENGTH x
    wid < $LINELENGTH =>
      x := LIST(fillerSpaces($LINELENGTH-wid,'" "),x)
      for y in x repeat brightPrint0 y
      NIL
    brightPrint0 x
    NIL
  y := NIL
  ok := true
  while x and ok repeat
    if CAR(x) in '(%l "%l") then ok := NIL
    else y := cons(CAR x, y)
    x := CDR x
  y := NREVERSE y
  wid := sayBrightlyLength y
  if wid < $LINELENGTH then
    y := CONS(fillerSpaces($LINELENGTH-wid,'" "),y)
  for z in y repeat brightPrint0 z
  if x then
    sayNewLine()
    brightPrintRightJustify x
  NIL

-- some hooks for older functions


BRIGHTPRINT x == brightPrint x

BRIGHTPRINT_-0 x == brightPrint0 x

--% Message Formatting Utilities

sayBrightlyLength l ==
  null l => 0
  atom l => sayBrightlyLength1 l
  sayBrightlyLength1 first l + sayBrightlyLength rest l

sayBrightlyLength1 x ==
  member(x,'("%b" "%d" %b %d)) =>
    NULL $highlightAllowed => 1
    1
  member(x,'("%l" %l)) => 0
  STRINGP x and STRINGLENGTH x > 2 and x.0 = '"%" and x.1 = '"x" =>
    INTERN x.3
  STRINGP x => STRINGLENGTH x
  IDENTP x => STRINGLENGTH PNAME x
  -- following line helps find certain bugs that slip through
  -- also see brightPrintHighlight
  VECP x => STRINGLENGTH '"UNPRINTABLE"
  ATOM x => STRINGLENGTH STRINGIMAGE x
  2 + sayBrightlyLength x

sayAsManyPerLineAsPossible l ==
  -- it is assumed that l is a list of strings
  l := [atom2String a for a in l]
  m := 1 + "MAX"/[SIZE(a) for a in l]
  -- w will be the field width in which we will display the elements
  m > $LINELENGTH =>
    for a in l repeat sayMSG a
    NIL
  w := MIN(m + 3,$LINELENGTH)
  -- p is the number of elements per line
  p := QUOTIENT($LINELENGTH,w)
  n := # l
  str := '""
  for i in 0..(n-1) repeat
    [c,:l] := l
    str := STRCONC(str,c,fillerSpaces(w - #c,'" "))
    REMAINDER(i+1,p) = 0 => (sayMSG str ; str := '"" )
  if str ^= '"" then sayMSG str
  NIL

say2PerLine l == say2PerLineWidth(l,$LINELENGTH / 2)

say2PerLineWidth(l,n) ==
  [short,long] := say2Split(l,nil,nil,n)
  say2PerLineThatFit short
  for x in long repeat sayLongOperation x
  sayBrightly '""

say2Split(l,short,long,width) ==
  l is [x,:l'] =>
    sayWidth x < width => say2Split(l',[x,:short],long,width)
    say2Split(l',short,[x,:long],width)
  [nreverse short,nreverse long]

sayLongOperation x ==
  sayWidth x > $LINELENGTH and (splitListOn(x,"if") is [front,back]) =>
    sayBrightly front
    BLANKS (6 + # PNAME front.1)
    sayBrightly back
  sayBrightly x

splitListOn(x,key) ==
  key in x =>
    while first x ^= key repeat
      y:= [first x,:y]
      x:= rest x
    [nreverse y,x]
  nil

say2PerLineThatFit l ==
  while l repeat
    sayBrightlyNT first l
    sayBrightlyNT
      fillerSpaces((($LINELENGTH/2)-sayDisplayWidth first l),'" ")
    (l:= rest l) =>
      sayBrightlyNT first l
      l:= rest l
      sayBrightly '""
    sayBrightly '""

sayDisplayStringWidth x ==
  null x => 0
  sayDisplayWidth x

sayDisplayWidth x ==
  PAIRP x =>
    +/[fn y for y in x] where fn y ==
      y in '(%b %d "%b" "%d") or y=$quadSymbol => 1
      k := blankIndicator y => k
      sayDisplayWidth y
  x = "%%" or x = '"%%" => 1
  # atom2String x

sayWidth x ==
  atom x => # atom2String x
  +/[fn y for y in x] where fn y ==
    sayWidth y

pp2Cols(al) ==
  while al repeat
    [[abb,:name],:al]:= al
    ppPair(abb,name)
    if canFit2ndEntry(name,al) then
      [[abb,:name],:al]:= al
      TAB ($LINELENGTH / 2)
      ppPair(abb,name)
    sayNewLine()
  nil

ppPair(abb,name) ==
    sayBrightlyNT [:bright abb,fillerSpaces(8-entryWidth abb," "),name]

canFit2ndEntry(name,al) ==
  wid := ($LINELENGTH/2) - 10
  null al => nil
  entryWidth name > wid => nil
  entryWidth CDAR al > wid => nil
  'T

entryWidth x == # atom2String x

center80 text == centerNoHighlight(text,$LINELENGTH,'" ")

centerAndHighlight(text,:argList) ==
  width := IFCAR argList or $LINELENGTH
  fillchar := IFCAR IFCDR argList or '" "
  wid := entryWidth text + 2
  wid >= width - 2 => sayBrightly ['%b,text,'%d]
  f := DIVIDE(width - wid - 2,2)
  fill1 := '""
  for i in 1..(f.0) repeat
    fill1 := STRCONC(fillchar,fill1)
  if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1)
  sayBrightly [fill1,'%b,text,'%d,fill2]
  nil

centerNoHighlight(text,:argList) == sayBrightly center(text,argList)

center(text,argList) ==
  width := IFCAR argList or $LINELENGTH
  fillchar := IFCAR IFCDR argList or '" "
  if (u:= splitSayBrightlyArgument text) then [text,:moreLines]:= u
  wid := sayBrightlyLength text
  wid >= width - 2 => sayBrightly text
  f := DIVIDE(width - wid - 2,2)
  fill1 := '""
  for i in 1..(f.0) repeat
    fill1 := STRCONC(fillchar,fill1)
  if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1)
  concat(fill1,text,fill2)

splitSayBrightly u ==
  width:= 0
  while u and (width:= width + sayWidth first u) < $LINELENGTH repeat
    segment:= [first u,:segment]
    u := rest u
  null u => NREVERSE segment
  segment => [:NREVERSE segment,"%l",:splitSayBrightly(u)]
  u

splitSayBrightlyArgument u ==
  atom u => nil
  while splitListSayBrightly u is [head,:u] repeat result:= [head,:result]
  result => [:NREVERSE result,u]
  [u]

splitListSayBrightly u ==
  for x in tails u repeat
    y := rest x
    null y => nil
    first y = '%l =>
      RPLACD(x,nil)
      ans:= [u,:rest y]
  ans


--=======================================================================
--                Utility Functions
--=======================================================================

$htSpecialChars := ['"_#", '"[", '"]", '"%", '"{", '"}", '"_\",
                    '"$", '"&", '"^", '"__", '"_~"]

$htCharAlist := '(
  ("$"  . "\%")
  ("[]" . "\[\]")
  ("{}" . "\{\}")
  ("\\" . "\\\\")
  ("\/" . "\\/" )
  ("/\" . "/\\" ) )

escapeSpecialChars s ==
  u := LASSOC(s,$htCharAlist) => u
  member(s, $htSpecialChars) => STRCONC('"_\", s)
  null $saturn => s
  ALPHA_-CHAR_-P (s.0) => s
  not (or/[dbSpecialDisplayOpChar? s.i for i in 0..MAXINDEX s]) => s
  buf := '""
  for i in 0..MAXINDEX s repeat buf :=
    dbSpecialDisplayOpChar?(s.i) => STRCONC(buf,'"\verb!",s.i,'"!")
    STRCONC(buf,s.i)
  buf

dbSpecialDisplayOpChar? c == (c = char '_~)