(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(FILECREATED "16-Jul-99 15:49:37" |{DSK}<project>medley3.5>sources>PAINTW.;3|
 16985  

      |changes| |to:|  (FNS PAINTW)

      |previous| |date:| "17-Jan-94 14:38:09" |{DSK}<project>medley3.5>sources>PAINTW.;1|)


; Copyright (c) 1986, 1990, 1992, 1994, 1999 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT PAINTWCOMS)

(RPAQQ PAINTWCOMS

       ((FNS PAINTW PAINTW.READMODE PAINTW.READBRUSHSHAPE PAINTW.READBRUSHSIZE PAINTW.READBRUSHSHADE
             PAINTW.READBRUSHTEXTURE PAINTW.READ.AND.SAVE.SHADE PAINTW.CACHE.SHADE PAINTW.SHADE.LABEL
             PAINTW.READCOMMAND)
        (COMS (INITVARS (PAINTW.SHADES))
              (GLOBALVARS PAINTW.SHADES))
        (DECLARE\: DONTEVAL@LOAD DOCOPY (P (PAINTW.CACHE.SHADE BLACKSHADE)
                                           (PAINTW.CACHE.SHADE GRAYSHADE)
                                           (PAINTW.CACHE.SHADE HIGHLIGHTSHADE)))
        (INITVARS (PAINTCOMMANDBRUSH '(ROUND 2))
               (PAINTCOMMANDMODE 'PAINT)
               (PAINTCOMMANDMENU)
               (PAINTCOMMANDSHADE BLACKSHADE)
               (PAINTSIZEMENU)
               (PAINTSHAPEMENU)
               (PAINTSHADEMENU)
               (PAINTMODEMENU)
               (PAINTWCURSOR))))
(DEFINEQ

(PAINTW

  (LAMBDA (WINDOW)                                           (* \; "Edited 16-Jul-99 15:49 by rmk:")

                                                             (* \; "Edited 16-Jul-99 15:48 by rmk:")

                                                             (* \; 

                                                      "Edited 17-Jan-94 14:27 by sybalsky:mv:envos")


(* |;;;| "allows the user to paint with the cursor")


(* |;;;| 

"should make sure cursor has moved or a button has change before proceeding with the inner loop.")


(* |;;;| "has some of the stuff to allow the brush to be an arbitrary bitmap but not all.")


    (SETQ WINDOW (\\INSUREWINDOW WINDOW))
    (|printout| PROMPTWINDOW "Left button paints;  Middle button erases.
Right button pops up a command menu.
To stop, select the QUIT command.")
    (RESETLST
        (RESETSAVE NIL (LIST 'CURSOR (CURSOR)))
        (PROG (DS BITSPERPIXEL MASKSHADE BRUSH MASK HOTX HOTY (PREVX -65535)
                  (PREVY -65535)
                  (PREVBUT -5))
              (TOTOPW WINDOW)                                (* \; 

                                                           "look for a previously stored brush.")

              (COND
                 ((SETQ BRUSH (WINDOWPROP WINDOW 'PAINTBRUSH))
                  (SETQ PAINTCOMMANDMODE (CAR BRUSH))
                  (SETQ PAINTCOMMANDSHADE (CADR BRUSH))
                  (SETQ PAINTCOMMANDBRUSH (CADDR BRUSH))))
              (SETQ DS (|fetch|
 (WINDOW DSP) |of|
 WINDOW))
              (SETQ BITSPERPIXEL (OR (|fetch|
 (SCREEN SCDEPTH) |of|
 (FETCH
 (WINDOW SCREEN
                                                                                              )
                                                                               OF
 WINDOW))
                                     (|fetch|
 (SCREEN SCBITSPERPIXEL) |of|

                                                                          (FETCH
 (WINDOW SCREEN)
                                                                             OF
 WINDOW))))
              (SETQ MASKSHADE (SELECTQ BITSPERPIXEL
                                  (1 BLACKSHADE)
                                  (MASK.1\'S 0 BITSPERPIXEL)))
          BRUSHLP
              (SETQ BRUSH (COND
                             ((BITMAPP PAINTCOMMANDBRUSH))
                             (T (\\GETBRUSH PAINTCOMMANDBRUSH))))
              (SETQ HOTX (HALF (|fetch|
 (BITMAP BITMAPWIDTH) |of|
 BRUSH)))
              (SETQ HOTY (HALF (|fetch|
 (BITMAP BITMAPHEIGHT) |of|
 BRUSH)))
              (SETQ PAINTWCURSOR
               (|create|
 CURSOR
                      CUIMAGE _ BRUSH
                      CUMASK _ BRUSH
                      CUHOTSPOTX _ HOTX
                      CUHOTSPOTY _ HOTY
                      CUDATA _ NIL |using|
 PAINTWCURSOR))
              (CURSOR PAINTWCURSOR)
              (COND
                 ((NOT (EQ BITSPERPIXEL 1))
                  (CURSORCOLOR PAINTCOMMANDSHADE)))          (* \; 

                                                "BRUSH can change if PAINTW is to color screen.  *")

              (SETQ BRUSH (|fetch|
 (CURSOR CUIMAGE) |of|
 PAINTWCURSOR))
              (SETQ MASK (|fetch|
 (CURSOR CUMASK) |of|
 PAINTWCURSOR))
          PAINTLP
              (GETMOUSESTATE)
              (COND
                 ((AND (IEQP PREVX LASTMOUSEX)
                       (IEQP PREVY LASTMOUSEY)
                       (IEQP PREVBUT LASTMOUSEBUTTONS))

                  (* |;;| "No movement, and no button changes.")


                  )
                 ((LASTMOUSESTATE RIGHT)
                  (SETQ PREVX LASTMOUSEX)
                  (SETQ PREVY LASTMOUSEY)
                  (SETQ PREVBUT LASTMOUSEBUTTONS)
                  (COND
                     ((OR (INSIDE? (DSPCLIPPINGREGION NIL DS)
                                 (LASTMOUSEX DS)
                                 (LASTMOUSEY DS))
                          (NOT (WHICHW LASTMOUSEX LASTMOUSEY)))
                                                             (* \; 

                                                           "inside the interior, give command menu")

                      (SELECTQ (PAINTW.READCOMMAND
)
                          (SHADE (SETQ PAINTCOMMANDSHADE (OR (PAINTW.READBRUSHTEXTURE
 
                                                                    BITSPERPIXEL)
                                                             PAINTCOMMANDSHADE))
                                 (GO BRUSHLP))
                          (MODE (SETQ PAINTCOMMANDMODE (OR (PAINTW.READMODE
)
                                                           PAINTCOMMANDMODE))
                                (GO BRUSHLP))
                          (SHAPE (RPLACA PAINTCOMMANDBRUSH (OR (PAINTW.READBRUSHSHAPE
)
                                                               (CAR PAINTCOMMANDBRUSH)))
                                 (GO BRUSHLP))
                          (SIZE (RPLACA (CDR PAINTCOMMANDBRUSH)
                                       (OR (PAINTW.READBRUSHSIZE
)
                                           (CADR PAINTCOMMANDBRUSH)))
                                (GO BRUSHLP))
                          (QUIT (RETURN))
                          NIL))
                     (T                                      (* \; "do the window menu")

                        (DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY)))))
                 ((AND (LASTMOUSESTATE LEFT)
                       (OR (EQ PAINTCOMMANDMODE 'REPLACE)
                           (NOT (EQ PAINTCOMMANDSHADE MASKSHADE))))
                                                             (* \; 

                                                           "painting in grey is slightly harder.")

                  (SETQ PREVX LASTMOUSEX)
                  (SETQ PREVY LASTMOUSEY)
                  (SETQ PREVBUT LASTMOUSEBUTTONS)
                  (COND
                     ((EQ PAINTCOMMANDMODE 'REPLACE)         (* \; "erase what is there now")

                      (BITBLT MASK 0 0 DS (IDIFFERENCE (LASTMOUSEX DS)
                                                 HOTX)
                             (IDIFFERENCE (LASTMOUSEY DS)
                                    HOTY)
                             NIL NIL 'INPUT 'ERASE)          (* \; "put in grey")

                      (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS)
                                                  HOTX)
                             (IDIFFERENCE (LASTMOUSEY DS)
                                    HOTY)
                             NIL NIL 'MERGE 'PAINT PAINTCOMMANDSHADE))
                     (T (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS)
                                                    HOTX)
                               (IDIFFERENCE (LASTMOUSEY DS)
                                      HOTY)
                               NIL NIL 'MERGE PAINTCOMMANDMODE PAINTCOMMANDSHADE))))
                 ((LASTMOUSESTATE (OR MIDDLE LEFT))
                  (SETQ PREVX LASTMOUSEX)
                  (SETQ PREVY LASTMOUSEY)
                  (SETQ PREVBUT LASTMOUSEBUTTONS)
                  (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS)
                                              HOTX)
                         (IDIFFERENCE (LASTMOUSEY DS)
                                HOTY)
                         NIL NIL 'INPUT (COND
                                           ((LASTMOUSESTATE MIDDLE)
                                            'ERASE)
                                           (T PAINTCOMMANDMODE))))
                 (T (SETQ PREVX LASTMOUSEX)
                    (SETQ PREVY LASTMOUSEY)
                    (SETQ PREVBUT LASTMOUSEBUTTONS)))
              (GO PAINTLP))
        (WINDOWPROP WINDOW 'PAINTBRUSH (LIST PAINTCOMMANDMODE PAINTCOMMANDSHADE (COPY 
                                                                                    PAINTCOMMANDBRUSH
                                                                                      ))))))

(paintw.readmode

  (lambda nil
                                                (* |rrb| " 1-DEC-82 17:29")

    (menu (cond
             ((|type?|
 menu paintmodemenu)
              paintmodemenu)
             (t (setq paintmodemenu (|create|
 menu
                                           items _ '((replace
 'replace 
                                                     "the screen bits are replaced by the brush bits"
                                                            )
                                                     (invert 'invert 
                                                  "the screen bits inverted whereever brush bits are"
                                                            )
                                                     (add
 'paint 
                                                 "the brush bits are added to the bits on the screen"
                                                          )))))))))

(paintw.readbrushshape

  (lambda nil
                                                (* |rrb| " 1-DEC-82 17:29")

    (menu (cond
             ((|type?|
 menu paintshapemenu)
              paintshapemenu)
             (t (setq paintshapemenu (|create|
 menu
                                            items _ '(diagonal vertical horizontal square round))))))
    ))

(paintw.readbrushsize

  (lambda nil
                                                (* |rrb| " 1-DEC-82 17:30")

    (menu (cond
             ((|type?|
 menu paintsizemenu)
              paintsizemenu)
             (t (setq paintsizemenu (|create|
 menu
                                           items _ '(16 8 4 2 1))))))))

(paintw.readbrushshade

  (lambda nil
                                                (* |rrb| " 7-Oct-85 14:30")

                                                             (* |reads| \a |shade|)

    (prog (shade)
          
          (* i |removed| |the| 16\x16 |case| |because| paintw |uses| |merge| |mode| |and| 

          |the| |alignment| |of| 16\x16 |texture| |is| |off| |in| |that| |case.|

          |When| |fixed| |at| |the| |menu| |item| ("16x16 shade"

          (quote |16X16|) "Allows creation of a 16 bits by 16 bits shade"))


          (selectq (setq shade (menu (|create|
 menu
                                            centerflg _ t
                                            title _ "Choose shade"
                                            items _ (append (|for|
 fillpat |in|
 paintw.shades
                                                               |collect|
 (list (car fillpat)
                                                                               (kwote (cadr fillpat))
                                                                               
                                                                    "changes filling to this pattern"
                                                                               ))
                                                           '(("4 x 4 shade" '|4X4| 
                                                        "Allows creation of a 4 bits by 4 bits shade"
                                                                    )))
                                            menubordersize _ 1)))
              (|4X4| (return (paintw.read.and.save.shade
)))
              (|16X16| (return (paintw.read.and.save.shade
 t)))
              (return shade)))))

(paintw.readbrushtexture

  (lambda nil
                                                (* |gbn:| "25-Jan-86 17:15")

    (selectq (bitsperpixel \\cursordestination)
        (1 (paintw.readbrushshade
))
        (menu (colormenu (bitsperpixel \\cursordestination))))))

(paintw.read.and.save.shade

  (lambda (16x16flg)
                                         (* |rrb| " 4-Oct-85 11:34")

          
          (* |reads| \a |new| |filling,| |confirms| |it| |with| |the| |user| |and| |adds| 

          |it| |to| paintw.shades)


    (prog (shade)
          (cond
             ((null (setq shade (editshade (cond
                                              (16x16flg (bitmapcreate 16 16))))))
                                                             (* |user| |aborted|)

              (return nil)))
          (paintw.cache.shade
 shade)
          (return shade))))

(paintw.cache.shade

  (lambda (shade)
                                            (* |rrb| " 4-Oct-85 11:32")

                                                             (* |adds| \a |shade| |to| |the| 

                                                             |global| |cache.|)

    (or (|for|
 entry |in|
 paintw.shades |when|
 (equal (cadr entry)
                                                      shade) |do|
 (return t))
        (cond
           (paintw.shades (nconc1 paintw.shades (list (paintw.shade.label
 shade)
                                                      shade)))
           (t (setq paintw.shades (list (list (paintw.shade.label
 shade)
                                              shade)))
              'added)))))

(paintw.shade.label

  (lambda (filling)
                                          (* |rrb| " 7-Oct-85 14:29")

          
          (* |creates| \a |bitmap| |label| |which| |fills| |it| |with| |the| |texture| 

          filling.)


    (prog ((bm (bitmapcreate (plus 8 (stringwidth "4 x 4 shade" menufont))
                      (fontprop menufont 'height))))
          (bltshade filling bm)
          (return bm))))

(paintw.readcommand

  (lambda nil
                                                (* |gbn:| "25-Jan-86 16:35")

    (menu (cond
             ((|type?|
 menu paintcommandmenu)
              paintcommandmenu)
             (t (setq paintcommandmenu (|create|
 menu
                                              items _ '((|SetMode| 'mode 
                                                    "Allows specification of how new bits are merged"
                                                               )
                                                        (|SetShade| 'shade 
                                                               "Allows specification of new shade.")
                                                        (|SetShape| 'shape 
                                                               "Allows specification of brush shape")
                                                        (|SetSize| 'size 
                                                             "Allows specification of the brush size"
                                                               )
                                                        (quit 'quit "Exits painting mode")))))))))
)

(RPAQ? PAINTW.SHADES
 )
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS PAINTW.SHADES)
)
(DECLARE\: DONTEVAL@LOAD DOCOPY 

(PAINTW.CACHE.SHADE
 BLACKSHADE)

(PAINTW.CACHE.SHADE
 GRAYSHADE)

(PAINTW.CACHE.SHADE
 HIGHLIGHTSHADE)
)

(RPAQ? PAINTCOMMANDBRUSH
 '(ROUND 2))

(RPAQ? PAINTCOMMANDMODE
 'PAINT)

(RPAQ? PAINTCOMMANDMENU
 )

(RPAQ? PAINTCOMMANDSHADE
 BLACKSHADE)

(RPAQ? PAINTSIZEMENU
 )

(RPAQ? PAINTSHAPEMENU
 )

(RPAQ? PAINTSHADEMENU
 )

(RPAQ? PAINTMODEMENU
 )

(RPAQ? PAINTWCURSOR
 )
(PUTPROPS PAINTW COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1992 1994 1999))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (1316 16344 (PAINTW 1326 . 9487) (PAINTW.READMODE 9489 . 10467) (PAINTW.READBRUSHSHAPE 
10469 . 10851) (PAINTW.READBRUSHSIZE 10853 . 11194) (PAINTW.READBRUSHSHADE 11196 . 13001) (
PAINTW.READBRUSHTEXTURE 13003 . 13282) (PAINTW.READ.AND.SAVE.SHADE 13284 . 13907) (PAINTW.CACHE.SHADE 
13909 . 14692) (PAINTW.SHADE.LABEL 14694 . 15127) (PAINTW.READCOMMAND 15129 . 16342)))))
STOP