(FILECREATED " 8-Feb-86 10:33:04" {ERIS}<LISPUSERS>KOTO>PRESSTOIP.;2 11647  

      previous date: "21-Feb-85 00:40:55" {ERIS}<LISPUSERS>PRESSTOIP.;6)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT PRESSTOIPCOMS)

(RPAQQ PRESSTOIPCOMS ((* PRESSTOIP -- Press to InterPress by Kelly Roach *)
                      (FILES DPRESS)
                      (CONSTANTS (MICASPERPOINT 32.2461))
                      (FNS PRESS.TO.IP PRESS.TO.IMAGESTREAM PTI.FONTALIST PTI.PAGE PTI.ED 
                           PTI.STRINGWIDTH PTI.DSPXPOSITION PTI.DSPYPOSITION)))



(* PRESSTOIP -- Press to InterPress by Kelly Roach *)

(FILESLOAD DPRESS)
(DECLARE: EVAL@COMPILE 

(RPAQQ MICASPERPOINT 32.2461)

(CONSTANTS (MICASPERPOINT 32.2461))
)
(DEFINEQ

(PRESS.TO.IP
  (LAMBDA (PRESSFILE IPFILE)                                              (* kbr: 
                                                                          "21-Feb-85 00:36")
    (PRESS.TO.IMAGESTREAM PRESSFILE IPFILE (QUOTE INTERPRESS))))

(PRESS.TO.IMAGESTREAM
  (LAMBDA (PRESSFILE FILE IMAGESTREAMTYPE)                                (* kbr: 
                                                                          "21-Feb-85 00:36")
    (PROG (PFD FONTALIST STREAM PSTREAM PDES)
          (COND
             ((NULL FILE)
              (SETQ FILE (PACKFILENAME (APPEND (LIST (QUOTE EXTENSION)
                                                     (COND
                                                        ((EQ IMAGESTREAMTYPE (QUOTE INTERPRESS))
                                                         (QUOTE IP))
                                                        (T IMAGESTREAMTYPE))
                                                     (QUOTE VERSION)
                                                     NIL)
                                              (UNPACKFILENAME PRESSFILE))))))
                                                                          (* Open STREAM *)
          (SETQ PFD (DPRESS.FILE PRESSFILE))
          (SETQ FONTALIST (PTI.FONTALIST PFD IMAGESTREAMTYPE))
          (SETQ STREAM (OPENIMAGESTREAM FILE IMAGESTREAMTYPE))            (* Get PDES *)
          (SETQ PSTREAM (fetch (PFD STREAM) of PFD))
          (SETQ PDES (for PDE in (fetch (PFD PDES) of PFD) when (EQ (fetch (PDE $TYPE) of PDE)
                                                                    (QUOTE PAGE)) collect PDE))
                                                                          (* Output PDES *)
          (PTI.PAGE PSTREAM (CAR PDES)
                 STREAM FONTALIST)
          (for PDE in (CDR PDES) do (PRIN1 (CHARACTER (CHARCODE ^L))
                                           STREAM)
                                    (PTI.PAGE PSTREAM PDE STREAM FONTALIST))
                                                                          (* Close streams *)
          (CLOSEF PSTREAM)
          (RETURN (CLOSEF STREAM)))))

(PTI.FONTALIST
  (LAMBDA (PFD IMAGESTREAMTYPE)                                           (* kbr: 
                                                                          "21-Feb-85 00:36")
                                                                          (* Compute font alist.
                                                                          *)
    (PROG (FAMILY SIZE PFONT FAKED ANSWER)
          (for FONTSET in (fetch (PFD FONTSETS) of PFD)
             do (for FDE in (fetch (FONTSET FDES) of FONTSET)
                   do (SETQ FAMILY (fetch (FDE $FAMILY) of FDE))
                      (SETQ SIZE (fetch (FDE SIZE) of FDE))
                      (SETQ PFONT (FONTCREATE FAMILY SIZE (fetch (FDE $FACE) of FDE)
                                         (fetch (FDE ROTATION) of FDE)
                                         (QUOTE PRESS)))
                      (SETQ FAKED (NOT (MEMB FAMILY (QUOTE (CLASSIC MODERN TERMINAL MATH SYMBOL)))))
                      (COND
                         ((AND (EQ FAMILY (QUOTE TIMESROMAN))
                               (IEQP SIZE 16))
                          (SETQ FAMILY (QUOTE MODERN))
                          (SETQ SIZE 18))
                         ((AND (EQ FAMILY (QUOTE HELVETICA))
                               (IEQP SIZE 11))
                          (SETQ FAMILY (QUOTE MODERN))
                          (SETQ SIZE 12))
                         ((EQ FAMILY (QUOTE SAIL))
                          (SETQ FAMILY (QUOTE MODERN))))
                      (SETQ FONT (COND
                                    ((EQ FAMILY (QUOTE NEWVEC))           (* Can't handle this 
                                                                          yet. *)
                                     (QUOTE BADFONT))
                                    (T (FONTCREATE FAMILY SIZE (fetch (FDE $FACE) of FDE)
                                              (fetch (FDE ROTATION) of FDE)
                                              IMAGESTREAMTYPE))))
                      (push ANSWER (LIST (fetch (FDE NUMBER) of FDE)
                                         FONT PFONT FAKED))))
          (SETQ ANSWER (DREVERSE ANSWER))
          (RETURN ANSWER))))

(PTI.PAGE
  (LAMBDA (PSTREAM PDE STREAM FONTALIST)                                  (* kbr: 
                                                                          "21-Feb-85 00:36")
                                                                          (* Output page PDE to 
                                                                          STREAM. *)
    (PROG NIL
          (for ED in (DPRESS.PAGE PSTREAM PDE) do (PTI.ED PSTREAM ED STREAM FONTALIST)))))

(PTI.ED
  (LAMBDA (PSTREAM ED STREAM FONTALIST)                                   (* kbr: 
                                                                          "21-Feb-85 00:37")
                                                                          (* Output entity 
                                                                          descriptor ED to STREAM.
                                                                          *)
    (PROG (LEFT BOTTOM FONTSET COMMANDS XADJUSTMENT LASTY BUCKET FONT PFONT)
          (SETQ LEFT (fetch (ENTITY LEFT) of (fetch (ED ENTITY) of ED)))
          (SETQ BOTTOM (fetch (ENTITY BOTTOM) of (fetch (ED ENTITY) of ED)))
          (SETQ FONTSET (fetch (ENTITY FONTSET) of (fetch (ED ENTITY) of ED)))
          (SETQ COMMANDS (DPRESS.COMMANDS PSTREAM ED))
          (SETQ XADJUSTMENT 0)
          (for COMMAND in COMMANDS as PCOMMAND in (CONS NIL COMMANDS) as NCOMMAND
             in (CDR COMMANDS)
             do (SELECTQ (CAR COMMAND)
                    (Show.characters 
                         (COND
                            ((NOT (EQ FONT (QUOTE BADFONT)))
                             (PRIN1 (CADR COMMAND)
                                    STREAM)
                             (SETQ XADJUSTMENT (IPLUS XADJUSTMENT (IDIFFERENCE (PTI.STRINGWIDTH
                                                                                (CADR COMMAND)
                                                                                FONT)
                                                                         (PTI.STRINGWIDTH
                                                                          (CADR COMMAND)
                                                                          PFONT)))))))
                    (Set.x (COND
                              ((OR (AND (EQ (CAR PCOMMAND)
                                            (QUOTE Set.y))
                                        (NOT (EQ (CADR PCOMMAND)
                                                 LASTY)))
                                   (AND (EQ (CAR NCOMMAND)
                                            (QUOTE Set.y))
                                        (NOT (EQ (CADR NCOMMAND)
                                                 LASTY))))                (* Absolute Set.x.
                                                                          *)
                               (PTI.DSPXPOSITION (IDIFFERENCE (CADR COMMAND)
                                                        LEFT)
                                      STREAM))
                              (T                                          (* Adjusted Set.x.
                                                                          *)
                                 (PTI.DSPXPOSITION (IDIFFERENCE (IPLUS (CADR COMMAND)
                                                                       XADJUSTMENT)
                                                          LEFT)
                                        STREAM))))
                    (Set.y (COND
                              ((EQ (CADR COMMAND)
                                   LASTY)                                 (* Ignore. *)
                               )
                              (T (PTI.DSPYPOSITION (IDIFFERENCE (CADR COMMAND)
                                                          BOTTOM)
                                        STREAM)
                                 (SETQ XADJUSTMENT 0)
                                 (SETQ LASTY (CADR COMMAND)))))
                    (Font (SETQ BUCKET (ASSOC (IPLUS (ITIMES 16 FONTSET)
                                                     (CADR COMMAND))
                                              FONTALIST))
                          (COND
                             ((NULL BUCKET)
                              (SHOULDNT)))
                          (SETQ FONT (CADR BUCKET))
                          (SETQ PFONT (CADDR BUCKET))
                          (COND
                             ((NOT (EQ FONT (QUOTE BADFONT)))
                              (DSPFONT FONT STREAM))))
                    (Nop                                                  (* No operation.
                                                                          *))
                    (Set.space.x                                          (* Why bother.
                                                                          *))
                                                                          (* not implemented yet))))))

(PTI.STRINGWIDTH
  (LAMBDA (STR FONT FLG RDTBL)                                            (* kbr: 
                                                                          "21-Feb-85 00:37")
    (PROG (ANSWER)
          (SETQ ANSWER (STRINGWIDTH STR FONT FLG RDTBL))
          (COND
             ((EQ (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)
                  (QUOTE DISPLAY))
              (SETQ ANSWER (FIXR (FTIMES ANSWER MICASPERPOINT)))))
          (RETURN ANSWER))))

(PTI.DSPXPOSITION
  (LAMBDA (XPOSITION STREAM)                                              (* kbr: 
                                                                          "21-Feb-85 00:37")
    (COND
       ((AND XPOSITION (EQ (IMAGESTREAMTYPE STREAM)
                           (QUOTE DISPLAY)))
        (DSPXPOSITION (FIXR (FQUOTIENT XPOSITION MICASPERPOINT))
               STREAM))
       (T (DSPXPOSITION XPOSITION STREAM)))))

(PTI.DSPYPOSITION
  (LAMBDA (YPOSITION STREAM)                                              (* kbr: 
                                                                          "21-Feb-85 00:37")
    (COND
       ((AND YPOSITION (EQ (IMAGESTREAMTYPE STREAM)
                           (QUOTE DISPLAY)))
        (DSPYPOSITION (FIXR (FQUOTIENT YPOSITION MICASPERPOINT))
               STREAM))
       (T (DSPYPOSITION YPOSITION STREAM)))))
)
(PUTPROPS PRESSTOIP COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (771 11562 (PRESS.TO.IP 781 . 1034) (PRESS.TO.IMAGESTREAM 1036 . 2954) (PTI.FONTALIST 
2956 . 5172) (PTI.PAGE 5174 . 5646) (PTI.ED 5648 . 10207) (PTI.STRINGWIDTH 10209 . 10686) (
PTI.DSPXPOSITION 10688 . 11123) (PTI.DSPYPOSITION 11125 . 11560)))))
STOP