#!/usr/local/bin/rexx

/*
 * Written in FORTRAN by an unknown user, probably for the ND-100
 * machine of the Studio-54 Student Computer Club at Norwegian 
 * Institute of Technology; probably sometime in the late seventies 
 * or early eighties. 
 * 
 * Ported to Rexx, and completely rewritten by Anders Christensen 
 * <anders@pvv.unit.no> in Autumn 1993. 
 */

   Version = '2.01'
   RelDate = '12 November 1993'

   Libdirs = "/usr/lib/svada:/local/lib/svada:/store/lib/rexx"

   MinParSize = 2    /* Min number of sentences in a paragraph */ 
   ParProb = 300     /* (1/100ths) probability of starting new paragraph */
   ParIndent = 3     /* Paragraph indentation in spaces */
   MaxColumns = 75   /* Max number of columns in output */
   ItemIndent = 5    /* Number of columns to indent items of lists */
   DefaultPath = ".:/local/lib:/store/lib/rexx"

/***** You should not need to change anything below this line *****/

   OutputFile = ''
   ExtraLibs = ReadEnvir( 'SVADADIR' )
   if ExtraLibs=='' then
      ExtraLibs = DefaultPath

   OutBuffer = ''
   InitOutput = 0 
   Column = ParIndent 
   OutputLines = 0

   parse arg args

   /* First, extract options */
   do while left(word(args,1),1)=='/'
      parse var args arg args
      parse var arg '/'name'='value

      pos1 = pos('=',value)
      if (pos1>0) then
         pos2 = lastpos('/',value,pos1)
      
      if pos1>0 & pos2>0 then do
         args = substr(value,pos2) args
         value = left(value,pos2-1)
         end

      name = translate(name)
      select
         when abbrev('START',name,1) then do
            if \datatype(value,'W') then
               call error 'Non-integer seed to pseudo-random generator:' value
            if value<0 then
               call error 'Seed for pseudo-random generator out of range:',
                          value
            if value>100000 then
               value = value % 100000

            call random ,, value
            end

         when abbrev('LIBRARY',name,1) then do
            if (left(value,1)==":") then
               ExtraLibs = ExtraLibs || value
            else if (right(value,1)==":") then
               ExtraLibs = value || ExtraLibs
            else
               ExtraLibs = value 
            end

         when abbrev('OUTPUT',name,1) then do
            OutputFile = value ;
            end
      
         when abbrev('INDENT',name,1) then do
            if \datatype(value,'W') then 
               call error 'Non-integer number of columns to indent:' value
            if value<0 then
               call error 'Number of columns to indent is out of range:' value
            ParIndent = value
            end

         when abbrev('COLUMNS',name,1) then do
            if \datatype(value,'W') then 
               call error 'Non-integer given for number of columns:' value
            if value<=0 then
               call error 'Number of columns is out of range:' value
            MaxColumns = value
            end

         otherwise
            call error 'Incorrect option specified:' name
         end
      end

   if ParIndent>=MaxColumns then
      ParIndent = 0 ;

   if left(ExtraLibs,1)==':' then
      ExtraLibs = substr(ExtraLibs,2)

   /*
    * The rest of the parameters are either number of line, or grammar
    * files. The manual page says that the parameters must have the 
    * number of lines first, and then one or more grammar files. 
    * This is actually not true, since the order of the number and 
    * the grammar files are irrelevant. The first parameter that is a
    * positive whole number is taken to be the number of lines, while
    * the rest of the parameters are taken to be grammar files.
    */
   Files = 0

   do while args<>''
      parse var args arg args
      if datatype(arg,'W') & OutputLines=0 then do
         if arg<=0 then 
            call error 'Number of sentences is not positive:' arg

         OutputLines = arg 
         end

      else do
         Files = Files + 1
         GrammarFiles.Files = ResolveFile( arg, ExtraLibs ) 
         end
      end

   if OutputLines=0 then do
      say '   svada  ---  version 'Version'  'RelDate
      say '   Syntax:  svada [options] number [grammar-file ...]'
      say
      say '   Parameters:'
      say '      number             Number of sentences to generate'
      say '      grammar-file       Definition of grammar for generated text'
      say
      say '   Options:'
      say '      /indent=value      Number of columns to indent the first line'
      say '                         of new paragraphs'
      say '      /colums=value      Width of output text in number of columns'
      say '      /output=filename   Name of the output file'
      say '      /start=number      Sets seed in pseudo-random generator'
      say '      /library=path      Set search path for grammar files'
      say
      say '   Svada is a pseudo-random text generator, which produces valid'
      say '   sentences from definitions of a grammar and a word vocabulary.'
      say '   See the svada manual page for more information.'
      exit 1
      end

   if Files=0 then
      Files = 1 

   flags. = ''

   do file=1 to files
      if file==1 & symbol('grammarFiles.file')='LIT' then do
         do while lines()>0
            queue linein()
            end
         end
      else do
         lines = lines(GrammarFiles.file)
         if lines=0 then do
            call warning 'empty or non-existent grammar file' GrammarFiles.file
            iterate file
            end

         /*
          * Then, stuff all the contents of the file on the stack. That way
          * we have isolated the file operations, so that we can freely 
          * play with the stack. Note that the lines() bif may behave very
          * differently from interpreter to interpreter.
          */
         if lines>1 then 
            do lines 
               queue linein(GrammarFiles.file)
               end
         else
            do while lines(GrammarFiles.file)>0
               queue linein(GrammarFiles.file)
               end
      end

      /* 
       * Read every section of the file, but first, ignore all input, 
       * until the first section starter is found
       */
      do ityp = 1 while queued()>0
         do while queued()>0
            parse upper pull start SectionName .
            if left(start,5)=='*****' then 
               leave 
            end

         /*
          * Empty lines, and lines starting with '#' are to be considered
          * comments, and should be ignored.
          */
      
         if symbol('lines.sectionname.0')='VAR' then 
            ifr = lines.sectionname.0 
         else
            ifr = 0

         do while queued()>0
            parse pull line

            if line='' & SectionName<>'TITLE' | left(strip(line),1)=='#' then 
               iterate

            if left(line,5)=='*****' then do
               push line
               leave
               end

            line = space(line)

            ifr = ifr + 1 
            parse value line with line '[' +0 rest
            do while rest\=''
               parse upper var rest . '[' flag ']' rest
               flags.SectionName.ifr = space(flags.SectionName.ifr flag)
               end

            lines.SectionName.ifr = line 
           end
         lines.SectionName.0 = ifr
         end
/*    call lineout , GrammarFiles.file  */
      end

   title = 'TITLE'
   grammar = 'GRAMMAR'
   entry = 'SVADA'

   /* 
    * Make sure that we have a 'GRAMMAR' section. If we don't, then 
    * that's a fatal error. 
    */
   if symbol('lines.grammar.0')='LIT' then
      call error 'no GRAMMAR section in grammar files'

   /* 
    * Then, do some magic manipulations to the grammar, in order to 
    * get all the proper variables set up.
    */
   call ParseGrammar

   Lines = 1 ;
   WidTitle = 0 ;
   if symbol('lines.title.0')<>'LIT' then do

      do i=1 to lines.title.0
         if length(lines.title.i) > WidTitle then
            WidTitle = length(lines.title.i)      
         end

      if (WidTitle<MaxColumns) then
         WidTitle = MaxColumns

      do i=1 to lines.title.0 
         call sayline center(lines.title.i,WidTitle)
         end

      call sayline ''
      end

   /* 
    * Make sure that the first line starts a paragraph. 
    */
   DoIndent = 1
   GraceList = 3
   do i=OutputLines to 1 by -1
      drop currflags.

      linetype = 'normal'
      select
         when i=OutputLines then do
            call SelectLines 'short', ''
            GraceList = GraceList - 1
            end

         when random()<100 & i>10 & GraceList<=0 then do
            linetype = 'list'
            GraceList = 3
            do random(3,6) 
               call SelectLines 'short', ''
               end
            end

         otherwise
            call SelectLines 'long', ''
            GraceList = Gracelist - 1
         end

      call UtterLines linetype
      end

   if Column>1 then
      call sayline ''

   exit 0

/*
 * This is the 'real' svada-generator. It uses the rules to put 
 * together a suitable set of terms, and stores these terms in a 
 * string on the stack. It also notes any new flags that are set
 * by this rule, and returns those flags to its caller. 
 *
 * RULE.<name>.0   -> number of available versions for rule=<name>
 * RULE.<name>.order  -> the order of the subterms in the phrase
      BUG? there can be more than one versjon for a rule, so they 
      cannot all have the same order?
 * FLAGS.<dict>.<element>  -> list of flags associated with the element 
 *    i.e. the word, in the specified dictionary
 * FLAGIN.<name>.<phrase>.<index>  -> the flags imported from the 
 *    dictionary to the rule by rule <name>, alternative <phrase> and 
 *    subterm <index>
 * 
 * Temporary variables:
 * I -> the index of the current subterm of the phrase
 *
 */
SelectLines: procedure expose rule. lines. prob. currflags. flags. flagin.,
                              flagout.

   parse upper arg type, currflags 
   if symbol('rule.type.0')<>'VAR' then 
      call error 'Non-existent rule <'type'> refered to'

   /* chose one of the possible versions */
   phrase = random(1,rule.type.0)

   newflags = ''
   order = rule.type.phrase.order

   /* iterate over subterms in predefined order */
   do ifake=1 while order<>''
      parse var order i order
      part = rule.type.phrase.i

      /* if term is a literal string, just add it */
      if prob.type.phrase.i == -1 then do
         buffer.i = rule.type.phrase.i
	 iterate ifake
         end
                  
      /* see if term should be there; possibility<100 */
      if symbol('prob.type.phrase.i')='VAR' then 
         if random()>prob.type.phrase.i*10 then do
	    buffer.i = ''
            iterate ifake 
    	    end

      /* if term refers to a word in a dictionary, handle it 
       * 
       * Variable used in this section of the routine
       *
       *  target -> index of chosen word in dictionary
       *  term -> the word chosen from dictionary
       */
      if symbol('lines.part.0')='VAR' then do
         target = random(1,lines.part.0)  /* select word from dict */
         term = lines.part.target  /* retrieve word from dict */

         /* Setup the termflags.<flg> compound to indicate wether or not 
          * the flag <flg> was set in term <target> in dict <part> */
         termflags. = 0
	 tmp = flags.part.target
         do while tmp<>''
	    parse var tmp flag tmp 
	    termflags.flag = 1 
            end
 
         /* Then, we have to modify existing flags, as stored in the 
          * variable CURRFLAGS. We first need to set the flags which 
          * have been turned on explicitly by the term in the dict. There
	  * are two conditions for this: a) the flag must be set for the 
          * term in the dict, and b) the flag must be imported from the
          * subterm in the rule */
         tmp = flagin.type.phrase.i  /* flags to export to rule */
         do while tmp<>''
            parse var tmp flag tmp
            if termflags.flag then do  /* the flag must perhaps be set */  
               if wordpos(flag,currflags)=0 then 
                   currflags = space(currflags flag)
               end
            else do /* the flag must perhaps be cleared */
               if wordpos(flag,currflags)>0 then 
                   currflags = delword(currflags,wordpos(flag,currflags),1)
               end
            end

         /* The we must handle macro expansion, for each macro in the 
            term, we must decide which alternativ to use */
         do while pos('{',term)>0
            parse var term pre '{' tag ':' post

            /* check to see if there is another "{" before next "}" */
	    if pos('{',post)>0 & pos('{',post)<pos('}',post) then do
	       level = 1  /* marker of nesting level */
	       do cptr=1 to length(post)
	 	  if substr(post,cptr,1)='{' then 
		     level = level + 1  /* start of nested macro */

		  if substr(post,cptr,1)=',' & level = 1 then do
                     /* found "," at top level, so we can defined if-part */
		     parse var post if =(cptr) .
	             elsestart = cptr + 1 
                     end

		  if substr(post,cptr,1)='}' & level = 1 then do
                     /* found "}" at top level, so we can defined else-part */
		     else = substr(post,elsestart,cptr-elsestart)
	             post = substr(post,cptr+1)
		     end

	          if substr(post,cptr,1)='}' & level > 1 then
		     level = level - 1  /* end of nested macro */

	          end
	       end
	    else
	       parse var post if ',' else '}' post

            /* after we have identified a macro, replace it by its value */
	    parse upper var tag tag
            if wordpos(tag,currflags)>0 then
               term = pre || else || post
            else
               term = pre || if || post 
            end 
         end

      /* if not a dictionary term, it must be another rule, handle it */
      else do

         /* First compile the flags to send to it, that is the flags that 
          * are currently set and which is to be exported to the rule. */
         useflags = ''
         tmpflags = currflags
         do while tmpflags<>''
            parse var tmpflags pflag tmpflags
            if wordpos(pflag, flagout.type.phrase.i)>0 then
               useflags = useflags pflag
            end

         /* Call the subrule with its designed flags, and take note of 
          * which flags it returns. */
         newflags = space( SelectLines( part, space( useflags ) ))

         /* For each of the flags exported from the subrule, clear the 
          * corresponding flag in CURRFLAGS, since it will be set again 
          * in the code immediately below */
         tmpflags = flagin.type.phrase.i
         do while tmpflags<>''
            parse var tmpflags pflag tmpflags
            if wordpos(pflag, currflags)>0 then 
               currflags = worddel(currflags, wordpos(pflags, currflags), 1)
         end

         /* Make sure that the returned flags are merged back into the 
          * current list of flags (CURRFLAGS), provided that the flags 
          * are listed in the export list of the subrule */
         do while newflags<>''
            parse var newflags pflag newflags
            if wordpos(pflag, flagin.type.phrase.i)>0 then
               currflags = currflags pflag
            end

         parse pull term
         end

      buffer.i = term
      end

   buffer = ''
   do i=1 to rule.type.phrase.0
      buffer = buffer buffer.i
      end

   push buffer
   return currflags 

/* 
 * This routine formats the output, and prints it out. It handles things 
 * like choosing when to start a new paragraph, using a list, and 
 * several other nice layout details. 
 */
UtterLines:
   parse arg ltype

   if ltype='list' then
      call sayline ''

   do while queued()>0
      parse pull line
      line = space(line) || '.'
      line = translate(left(line,1)) || substr(line,2)

      do forever
         pos = pos(' ,', line )
         if (pos>0) then
            line = left(line,pos-1) || substr(line, pos+1)
         else
            leave
         end

      if right(line,2)=',.' then
         line = left(line,length(line)-2) || '.'
     
/*      do until sing='' & plur=''
         parse var line pre '{' sing ',' plur '}' post
         line = pre || sing || post 
         end */

      /* We may want to have a paragraph break */
      if ltype='list' | Lines>MinParSize & random()<ParProb then do
         if Column>1 then 
            call sayline ''

         Lines = 1
         if (ltype='list') then do
            Column = ItemIndent
            call saychars copies(' ',ItemIndent-2)
            end
         else; if ParIndent=0 then do
            call sayline ''
            Column = 0 
            end
         else; do
            Column = ParIndent
            call saychars copies(' ',Parindent)
            end
         end
      else
         Lines = Lines + 1

      if ltype='list' then
         call saychars '* '

      do while Line<>''
         Space = Max(1, MaxColumns - Column)
         if Space<length(Line) then 
            Point = lastpos(' ', Line, Space )
         else
            Point = length(Line)

         if point=0 & (column=1&ltype<>'list'|column=Itemindent&ltype='list') 
            then do
            point = pos(' ',Line)
            if point=0 then 
               point = length(line)
            end
  
         if Point=0 then do
            call sayline ''
            Column = 1 
            if ltype='list' then do
               call saychars copies(' ',ItemIndent)
               column = ItemIndent
               end
            end
         else do
            call saychars left(Line, Point)
            Line = substr(Line,Point+1)
            Column = Column + Point+1 
            end
         end

      if column < Maxcolums then do
         call saychars ' '
         column = column + 1
         end 

      if ltype='list' then 
         call sayline '' 
      end

   if ltype='list' then do
      call sayline ''
      if column>=parindent then do
         call saychars copies(' ',ParIndent)
         column = ParIndent 
         end
      else do
         Column = 1 
         end
      end
   return

saychars: 
   OutBuffer = OutBuffer || arg(1)
   return

sayline:
   call saychars arg(1)
   if OutputFile='' then
      say OutBuffer 
   else do
      if \InitOutput then do
         call lineout OutputFile,,1
         InitOutput = 1
         end

      call lineout OutputFile, OutBuffer
      end

   OutBuffer = ''
   return

/* 
 * This routines parses the grammar, which must be stored in:
 *      LINES.grammar.n
 * Where 'n' is a number from 1, and 'LINES.grammar.0' holds the 
 * number of the last line in the grammar.
 */
ParseGrammar: procedure expose lines. prob. flagin. flagout. rule.
   ruleline = 1
   Flagin. = ''
   Flagout. = '' 
   do while ruleline<=lines.grammar.0
      call StackRule
      call NoteRule
      end

   return

/*
 * This routine reads one grammar rule, and stacks the name of the 
 * rule, and the productions of the rules, fifo. 
 */
StackRule: procedure expose ruleline lines. prevname
   maxlines = lines.grammar.0
   if ruleline>maxlines then 
      return

   parse var lines.grammar.ruleline name '=' rule 
   if name='' | rule='' then 
      call error 'Syntax error while parsing svada grammar'

   queue space(name)
   queue space(rule)

   ruleline = ruleline + 1
   do while ruleline<=maxlines & pos('=',lines.grammar.ruleline)=0
      parse var lines.grammar.ruleline junk '|' rule
      if junk\='' then 
         call error 'Junk in front of rule in svada grammar'

      queue space(rule)
      ruleline = ruleline + 1 
      end

   return 

/* 
 * This routine parses the grammar rule, and sets up the correct 
 * variable for later use. 
 */
NoteRule: procedure expose prob. flagin. flagout. rule.
   if queued()>0 then
      parse upper pull name

   do rules=1 while queued()>0
      Repetitions = 1
      Skip = 0
      parse pull rule
      do x=1 while rule<>''
         rule = space(rule)

         /*
          * First, check that the next term starts with a '$', and 
          * handle that case
          */
         if left(rule,1)=='$' then  do
            parse var rule '$('temp')' rule 
            parse upper var temp rule.name.rules.x ',' rest
            do while rest\=''
               parse var rest term ',' rest
               select 
                  when datatype(term,'NUM') then
                     prob.name.rules.x = term
                  when left(term,1)='<' then 
                     flagin.name.rules.x = flagin.name.rules.x substr(term,2) 
                  when left(term,1)='>' then
                     flagout.name.rules.x = flagout.name.rules.x substr(term,2)
                  otherwise
                     call error 'Invalid form of term in a rule'
                     end
               end
            end

         else if left(rule,1)=='"' then do
            parse var rule '"' rule.name.rules.x '"' rule
            prob.name.rules.x = -1
            end

         else if left(rule,1)=='(' then do
            parse var rule '('temp')' rule
            if rule<>'' | \datatype(temp,'Whole') then 
               call error 'Syntax error while parsing svada grammar'

            Skip = 1 
            Repetitions = temp 
            end         

         else
            call error 'Syntax error while parsing svada grammar'
         end   
     
      rule.name.rules.0 = x - 1 - Skip

      do ixx=1 to Repetitions-1
         newrule = rules+ixx
         rule.name.newrule.0 = rule.name.rules.0
         do jxx=1 to rule.name.rules.0 
            rule.name.newrule.jxx = rule.name.rules.jxx
            if ('prob.name.rules.jxx')=='VAR' then
               prob.name.newrule.jxx = prob.name.rules.jxx
            end
         end

      justin = ''
      inandout = ''
      therest = ''
      natural = ''
      do xx=rule.name.rules.0 to 1 by -1 
	 natural = natural xx
         select
	 when flagin.name.rules.xx<>'' & flagout.name.rules.xx='' then 
	    justin = justin xx
	 when flagin.name.rules.xx<>'' then
	    inandout = inandout xx
	 otherwise
	    therest = therest xx
	    end
         end
      rule.name.rules.order = space(justin inandout therest) 
/*      rule.name.order = space(natural) */

      rules = rules+(repetitions-1)
      end

   rule.name.0 = rules-1
   return

error:
   parse arg message
   say 'Svada: Fatal error:' message
   exit 1

warning:
   say 'Svada: Warning:' arg(1) 
   return 

novalue:
   say ''
   say '   <<'sourceline(sigl)'>>>'
   say 'Novalue condition in line' sigl 'for variable' condition('d')
   exit 1

ReadEnvir: procedure
   parse arg name

   parse version system .

   if (left(system,11)=='REXX-Regina') then
      res = value(name,,'SYSTEM')
   else
      res = ''

   return res

ResolveFile: procedure
   parse arg name, path
   if pos('/',name)==0 then
      if lines(name)>0 then 
         return name

   do while path<>''
      parse var path dir ":" path
      if (dir=='/') then
         dir = ''
   
      fullname = dir'/'name
      if lines(fullname)>0 then
         return fullname
      end
         
   call warning 'Couldn''t find data file:' name 
   return ''