PROGRAM TYPESET; 
(*$R+*)
(* Version 4.10 1982     Per Stangeland*)
(* Translated into English Nov. 27th, 1982 - Per Stangeland *)
CONST
    no_of_codes = 21;

  VAR 
    inn,(*WS- text*)
    ut, (*Output file*)
    par, (*parameter file*)
    skjerm (*dvs. vanlig output, m} defineres for prosedyre ASCII*) : text; 
    ior,
    i : integer; 
    tegn : char; 
    navn : string; 
    symbol : ARRAY [1..no_of_codes] OF string; 

  EXTERNAL PROCEDURE @HLT; 

  PROCEDURE ASCII(VAR print : text; ch : char); 

    BEGIN
    IF ord(ch) = 255 THEN
      ch := '?'; 
    clrbit(ch,7); 
    IF ord(ch) < 32 THEN
      ch := '?'; 
    write(print,ch); 
    END; (*ASCII*)

  PROCEDURE convert(VAR s,d : text); 
(* S = input file, D = output file. The S file is read, character by
   character, by the CASE statement- line 258.
  Special printer symbols are put into the buffer through procedure enter.
  Ordinar� ASCI� character� ar� pu� int� th� buffe� throug� th� �
  I� statemen� in line 280. Symbo� fo� EOL�/en� o� paragrap� are entered
  b� th� nex� IF� Chec� fo� do� commands are done at the beginning of a 
  file and after each EOLN. Other symbols found in file S will be disregarded. 
  The D- file is written in 4 K blocks whenever the buffer is full.*)

    CONST
(*ASCII symbols used by Wordstar. Decimal notation.*)
      SKIP = 0; (* characters that should not be transferred are set to 0 hex*)
      fat = 2; (*backspace and double print*)
      bel = 7;  (*bell*)
      bs = 8;   (*back space ?*)
      tab = 9; 
      lf = 10; 
      softline = 13; (*A "true" chr 13 will be trapped by the EOLN
                      check. Softline is an 8D hex after clrbit.*)
      ns = 15; 
      underline = 19; 
      halfup = 20; 
      softhy = 30; 
      hy = 31; 
      space = 32; 
      quote = 34;
      max = 4080;
      bufsize = 4095; (*count may exceed max when
              a long printer symbol is entered into the file. The buffer
              size is therefore set to max+15 to prevent overflow.*)

    VAR 
      LAST_SYMBOL,
      idx,
      count,  (*counts characters put into the buffer*)
      i : integer; 
      buff :ARRAY [0..bufsize] OF char; (* 1..bufsize gives overflow. Why?*)
      ch  : char; 
      normaltext,fat_test,under_test,quote_test,half_test: boolean; 
    (*Set to FALSE in Switch, when printing in special typesets is in effect*)
      dotcommand : string; 

    PROCEDURE Dot; 
     (*DOT is called at every end- of line encountered in the S - file. 
       It detects dot commands. No action is taken if the first symbol
       on a new line is not a '.'    *)
 
      PROCEDURE lineheight; 
      (* Used by procedure dot to interpret line height symbols in the
         WS file. '.LH 10' or 'LH 12' (1 1/2 and double spaced lines)
         start a normal text sequence. '.LH 8' (narrow lines) is assumed
         to indicate a quotation sequence. This sequence is marked by
         symbol 3 (start) and symbol 5 (end) in the output file. Symbol
         2 and 4 should be alternate character sets.           *)

        VAR 
          Digit,
          L,
          i,
          NO : integer; 

        BEGIN
        NO := 0; 
        delete(dotcommand,1,3); (*remove the .lh *)
        L := length(dotcommand); 
        IF (L = 0) THEN
          undefined; 
        FOR i := 1 TO L DO
          BEGIN (*transform string characters to integers*)
                (*works OK in the 0 to 32767 range - no warning given 
                  for larger numbers. Non-integer values are
                  ignored.*)
          Digit := ord(dotcommand[i]) - 48; 
          IF digit in [0..9] THEN NO := NO * 10 + digit; 
          END; 
        CASE NO OF 
          8 : switch(3,0,normaltext); (*normaltext is never false when a
 					.lh 8 is encountered. Enter 3 is
					assumed to give a special typeset
					for quotations. Is is terminated
					when the text contains a .lh 10,
			                with enter 5..
				        Normal printing is indicated by
                                        Enter 2 - at the beginning of a
					text and after quotations. *)
 
          10 : BEGIN if normaltext then enter(2)
               ELSE BEGIN
                     enter(5);  
                     enter(2);
                     normaltext:=true;
		    END;	 
               END;
          12 :  BEGIN if normaltext then enter(4)
               ELSE BEGIN
                     enter(5);  
                     enter(4);
                     normaltext:=true;
		    END;	 
               END;(*.lh 12*)
         ELSE undefined;
        END;  (*CASE*)
        END; (*lineheight*)

(********************   DOT            ***********************)

      BEGIN
      IF EOF(S) THEN exit;
      ch := S^; 
      WHILE ch = '.' DO
        BEGIN
        readln(s,dotcommand); 
        CASE dotcommand[2] OF 
          'l','L' : 
            lineheight; 
          'p','P' : 
            enter(1); 
          ELSE undefined;
        END; (*CASE*)
        ch := s^; 
        END; (*WHILE*)
      END; (*DOT*)

(****************   UNDEFINED    ******************************)
(* Called by DOT at a command that requires operator intervention.
   Also called by ENTER if 'normaltext' is FALSE at a '.LH 8' state-
   ment. (E.G. two .lh 8 in a row.                          *)
 
   PROCEDURE undefined; 
       Var i: integer;
        BEGIN
        write(chr(BEL));
        writeln;
        writeln('udefined dot command: ',dotcommand); 
        writeln('write a parameter number and press RETURN'); 
        writeln('write a 0 if this command should be disregarded');
        readln(i); 
        IF (I in [1..no_of_codes]) THEN
          enter(i); 
        END; 
    
(*******************  ENTER   **********************************)
    PROCEDURE enter(code : integer); 

      VAR 
        i : integer; 
        this_symbol : string; 
        SUBSTITUTE: CHAR;

      BEGIN
      If code in [1..no_of_codes] then This_symbol := symbol[code]
       ELSE BEGIN undefined; exit; END; 
      SUBSTITUTE:=this_SYMBOL[1];

      CASE SUBSTITUTE OF
      '$': (*A '$' symbol means a standard ASCII end of line. These symbols
             cannot be present in the parameter file, since end of line
             is used as separator between symbols.*) 
          BEGIN 
            Buff[count]:=chr(13);
            Buff[count+1]:=chr(10);
            count:=count+2;
          END;
      '@':EXIT; (*A chr(64) in the FOTOSATS.PRM means that no action is taken
                  at the corresponding ENTER number. Example: A '@' at line 11
		  in FOTOSATS.PRM means that soft hyphens are omitted in the
                  output text.*) 
ELSE
    BEGIN
        FOR i := 1 TO length(this_symbol) DO
        BEGIN
        buff[count] := this_symbol[i]; 
        count := count + 1; 
        END;(*FOR*) 
    END; (*ELSE*)  
   END; (*CASE*)
    LAST_SYMBOL:=CODE;
END; (*enter*)

    PROCEDURE Switch(start,stop : integer; VAR normal: Boolean); 
    
    (* Determines if a special symbol marks the start or the end of a
       sequence. Calls enter to write the correct symbol to the output
       buffer. *)

      BEGIN
      IF normal THEN (* TRUE switch to special print symbol*)
        BEGIN
        normal := false; 
        enter(start);
        END
      ELSE (* FALSE End of special text - switch back to normal print*)
        BEGIN
        Normal := true; 
        Enter(stop); 
        END; 
      END; (*Switch*)

(*****************  CONVERT    *******************************)

    BEGIN
    normaltext := true; 
    fat_test:=true;
    under_test :=true;;
    half_test :=true;;
    quote_test :=true;
   count := 1; 
    dot; 
    WHILE not eof(s) DO
      BEGIN
      WHILE (not eof(s)) and (count < max) DO
        BEGIN
        WHILE (not eoln(s)) and (count < max) DO
          BEGIN
          ch := S^; 
          ASCII(skjerm,ch); 
          get(s); 
          clrbit(ch,7); 
          CASE ord(ch) OF 
            space :IF (BUFF[COUNT-1] =' ') OR (LASTSYMBOL=20) 
                   THEN CH:=CHR(SKIP); 
                      (*First space character is kept. Additional
                      space is skipped. No space after hard eoln.*)
            fat:      switch(8,9,fat_test);
            underline:switch(10,11,under_test);
            halfup:   switch(12,13,half_test);
            quote:    BEGIN switch(14,15,quote_test); ch:=chr(skip);END;
            hy:       enter(17);
            softhy:   enter(17);
            ns:       enter(18);
            softline: IF (buff[count-1] =' ') OR (lastsymbol = 17) then
		      ch:=chr(skip) ELSE enter(19);
		      (*soft line shifts are removed when the last 
			character on that line was a space character or
                        a soft hyphen. Symbol 19 - usually a space
                        character - is entered when line shift
                        is the only delimiter between two words in 
                        the text.*)
            tab:      enter(21);                      
          END; (*Case*)

          IF ch in [' '..'~'] THEN (*Enter ordinary ASCII symbols*)
            BEGIN
            buff[count] := ch; 
            count := count + 1; 
            last_symbol:=0;            
            END; (*IF*)
          END; (*while not eoln*)
        IF (eoln(s)) AND (not eof(s))THEN (*Enter end-of-line symbol*)
          BEGIN
          Readln(s); 
          IF lastsymbol <> 20 THEN Enter(20);
          (*The first RETURN is kept,following ones are removed*) 
          Dot;               (* check for dot commands*)
          END; (*IF*)
      IF (count <1) OR (count>max) then  writeln(count); 
  END; (*while not EOF and count < max *)

(******************  WRITE PHASE    ***************************)
      Writeln;
      WRITELN(' File ',navn,' is written - please wait'); 
      FOR idx := 1 TO count - 1 DO
        BEGIN
        d^ := buff[idx]; 
        put(d); 
        END; (*FOR*)
       Count:=1; (*start a new buffer*)
      END; (*while not eof*)
    END; (*procedure convert*)

  (**********************************************************
         MAIN PROGRAM                                      **)

  BEGIN
  REPEAT
    write('Name of Wordstar- file: '); 
    readln(navn); 
    open(inn,navn,ior); 
    IF ior = 255 THEN
      writeln('Cannot find ',navn); 
  UNTIL ior < 255;
  I:=Pos('.',navn);
  IF I>0 THEN delete(navn,I,length(navn)-I+1);
  navn:=concat(navn,'.SET');
  open(ut,navn,ior); 
  IF ior <> 255 THEN
    BEGIN
    write('the file ',navn,' already exists. Should it be removed? (Y/N)'); 
    read(tegn); 
    readln; 
    IF not (tegn in ['Y','y']) THEN
      @hlt; 
    END; 
  rewrite(ut); 
  assign(skjerm,'CON:'); 
  rewrite(skjerm); 
  open(par,'TYPESET.PRM',I); 
  IF i = 255 THEN
      BEGIN
      writeln('Cannot find "TYPESET.PRM" '); 
      @hlt; 
      END; 
  FOR i := 1 TO no_of_codes DO 
     BEGIN
       IF eof(par) then writeln('not enough symbols in  "TYPESET.PRM"')
       ELSE readln(par,symbol[i]); 
     END;
  writeln('Files are opened- conversion starts');
  IF not eof(inn) THEN
    convert(inn,ut); 
  close(ut,ior); 
  IF ior < 255 THEN
    writeln('file ',navn,' is written.'); 
  END. (*TYPESET*)