%endoflist
! 
! PR_1:GRAPH.INC - graphics routines, based on Fmacs:Frame with additions
!
! Modified by IMN to use the new Mouse boards...
%const %integer Frame Addr = 16_E00000
@Frame Addr %integerarray Frame(0:32767)
@16_E20002 %short Origin Reg
@16_E20001 %byte Colour Reg
@16_E20000 %byte Enable Reg
@16_E30000 %short %integer %array Colour Map (0:511)

! MOUSE constants and locations
!
@16_7F400 %short %integer mouse x
@16_7F402 %short %integer mouse y
!@16_7FFF0 %short MouseX
!@16_7FFF2 %short MouseY
!@16_7FFF4  %byte MouseButtons
!@16_7FFF4  %byte MsButtons

%constant %integer mouse left=1, mouse middle=2, mouse right=4

%integerfn mouse buttons
%constinteger flip = mouseleft+mouseright, mask = flip+mousemiddle
@16_7F45B %byte %integer duartinp
%integer b
  b = duartinp>>1&mask
  %result = b %if b&flip=0 %or b&flip=flip
  %result = b!!flip
%end

%const %real Level 0 = 0, Level 1 = 1, Level 15 = 1.5, Level 2 = 2
%own %real APM Level = 1
%ownbyte Mouse Flag
%const %string (1) nls = "
"
!
! Values returned by MouseButtons
!
!%const %byte MsNone = 248,
!             MsL    = 249,
!             MsM    = 250,
!             MsLM   = 251,
!             MsR    = 252,
!             MsLR   = 253,
!             MsMR   = 254,
!             MsLMR  = 255

%const %byte MsNone = 0,
             MsL    = 1,
             MsM    = 2,
             MsLM   = 3,
             MsR    = 4,
             MsLR   = 5,
             MsMR   = 6,
             MsLMR  = 7
!
! Colour & Plane Constants
!
%const %byte Black = 0,
             Red = 1,
             Green = 2,
             Blue = 4,
             Yellow = Red + Green,
             Magenta = Red + Blue,
             Cyan = Blue + Green,
             White = Red + Blue + Green,
             Invert = 8,
             RGB Plane = 7

%own %integer Current Colour
%ownshort Hi Font
%ownbyte Font Append

%routine Wait (%integer MS)
%integer T
   T = MS + Cpu Time
   %cycle
   %repeat %until Cpu Time >= T
%end

! MOUSE FLAG = 1 %if there is a Mouse attached
!
%routine Check for Mouse
%byte Dummy
   %on 0 %start
      Mouse Flag = 0
      %return
   %finish
   Dummy = MouseButtons
   Mouse Flag =1
%end

!%routine Offset(%integer x,y)
!  Origin Reg <- x>>4&63+(y+511)<<6
!%end

%routine Set Colour(%integer C)
  Current Colour = C
  Colour Reg = Current Colour
%end

%routine Disable (%integer Planes)
  Enable Reg = Planes!!255
%end

%routine Mix Colour (%short Col, Red, Green, Blue)
   Colour Map(Col<<1+1)=Red+Green<<5+Blue<<10
%end

%routine Mix Image (%short %array %name CM (0:511), %integer C, R, G, B)
   CM (C<<1+1)=R+G<<5+B<<10
%end

%routine Mix and Set (%short Col, Red, Green, Blue)
   Colour Map((Col&255)<<1+1)=(Red&31)+(Green&31)<<5+(Blue&31)<<10
   Current Colour = Col; Colour Reg = Current Colour
%end

%routine Map Cycle (%integer C1, C2, Val, %short %array %name CM (0:511))
%integer i, T=C2-C1
   Colour Map ((i+C1)<<1+1)=CM((Rem(i+Val,T+1)+C1)<<1+1) %for i=0,1,T
%end

%external %routine %spec vline %alias "FRED_GRAPHICS_VLINE" (%integer x, y0, y1)
%external %routine %spec hline %alias "FRED_GRAPHICS_HLINE" (%integer x0, x1, y)
%external %routine %spec clear %alias "FRED_GRAPHICS_CLEAR"
%external %routine %spec half clear %alias "FRED_GRAPHICS_HCLEAR" (%integer h)
%external %routine %spec line %alias "FRED_GRAPHICS_LINE" %c
                                                       (%integer x0, y0, x1, y1)
%external %routine %spec fill %alias "FRED_GRAPHICS_FILL" %c
                                                       (%integer x0, y0, x1, y1)
%external %routine %spec Circle %alias "FRED_GRAPHICS_DISC" (%integer x, y, r)
%external %routine %spec Round %alias "FRED_GRAPHICS_RING" (%integer x, y, r)
%external %routine %spec plot %alias "FRED_GRAPHICS_PLOT" (%integer x, y)
%external %routine %spec triangle %alias "FRED_GRAPHICS_TRIANGLE" %c
                                               (%integer x0, y0, x1, y1, x2, y2)
%routine Trapeze (%record (*) %name s1,s2)
  *move.l d5,-(sp)
  *move.l (a0)+,d0
  *move.l (a0)+,d1
  *move.l (a0),d2
  *move.l (a1)+,d3
  *move.l (a1)+,d4
  *move.l (a1),d5
  *move.l #16_1174,a0
  *jsr (a0)
  *move.l (sp)+,d5; *clr d4
%end

!%external %routine %spec trapeze %alias "FRED_GRAPHICS_TRAPEZE" %c
!                                           (%integer x00, x01, y0, x10, x11, y1)
%external %routine %spec paint %alias "FRED_GRAPHICS_PAINT" %c
                     (%integer %name s, %integer x0, y0, x1, y1, offset, stride)
%external %routine %spec poly %alias "FRED_GRAPHICS_POLY" (%integer x, y)
%external %routine %spec closepoly %alias "FRED_GRAPHICS_CLOSEPOLY"

%external %routine %spec offset %alias "FRED_GRAPHICS_OFFSET" (%integer x, y)
!%external %routine %spec colour %alias "FRED_GRAPHICS_COLOUR" (%integer colour)
!%external %routine %spec enable %alias "FRED_GRAPHICS_ENABLE" (%integer planes)
!%external %routine %spec update colour map %alias "FRED_GRAPHICS_UPCMAP" %c
!                                                 (%half %integer %name new map)
!%external %routine %spec textat %alias "FRED_GRAPHICS_TEXTAT" (%integer x,y)
!%external %routine %spec readfont %alias "FRED_GRAPHICS_READFONT" %c
!                                        (%string(255) file, %integer %name font)
!%external %routine %spec showsymbol %alias "FRED_GRAPHICS_SHOWSYM" %c
!                                                                    (%integer k)
!%external %routine %spec showstring %alias "FRED_GRAPHICS_SHOWSTR" %c
!                                                                (%string(255) s)
!%external %routine %spec font %alias "FRED_GRAPHICS_FONT" (%integer f)

%routine VClear
   Print Symbol (27); Print Symbol (118)
%end

%routine Clear All
   VClear
   Clear
%end

%routine Clear and Set
  Clear
  Set Colour (Current Colour)
%end

! FONT handling routines
! The layout of the array is as follows:
! For 0<=i<=255, let p(i)=j
! p(j) is height of character i
! p(j+1) is width of character i
! p(j+2) to p(j+p(j)+1) describe the character

%integerarray Font(0:5999)

%const %string (255) Default Font = "Fmacs:Font.Visual"

%routine Read Font (%string (255) File)
%owninteger Index=128, Num Chars
%integer Char,Num,i,n,Min,Max

   %integer %fn Reverse (%integer N)
      *Move.l N,d0
      *Clr.l  d1
      *Move.w #31,d2
   L: *Roxr.l #1,d0
      *Roxl.l #1,d1
      *Dbra   d2,L
      *Move.l d1,N
      %result = N
   %end

   Open Input(3, File)
   %if Font Append = 0 %start
      Font(i) = 256 %for i=0,1,255
      Font(256) = 0; Font(257) = 0
      Index = 258; Hi Font = 0
   %finish %else Font Append = 0
   read(Min); read(Max); Num Chars = Max - Min
   %for char=0,1,Num Chars %cycle
      readsymbol(num) %until num=':'
      font(Hi Font + char)=index
      read(num); font(index)=num; index=index+1
      read(font(index))
      %for i = num,-1,1 %cycle
         Read (N)
         font(index+i) = Reverse (N)
      %repeat
      index = index+num+1
   %repeat
   Hi Font = Hi Font + Num Chars + 1
   closeinput; selectinput(0)
%end

%routine Append Font (%string (255) File)
   Font Append = 1
   Read Font (File)
%end

%routine Read Default Font
   Read Font (Default Font)
%end

%owninteger xpos=0, ypos=0

%routine At(%integer x,y)
  xpos = x; ypos = y
%end

%routine Show Symbol (%integer k)
%integer q = Frame Addr + (ypos&1023)<<7+(xpos&1023)>>4<<1
%integer shiftcount = xpos&15
%integer p = addr(font(font(k&255)))+4
%integer height = integer(p-4)
  xpos = xpos+integer(p)
  %returnif height=0
  *move.l p,a0
  *move.l q,a1
  *move.l height,d0
  *move.l (a0)+,d1;  !width
  *moveq #-128,d2
  *move.l shiftcount,d3
loop: *move.l (a0)+,d4
      *lsr.l d3,d4
      *move.l d4,(a1)
      *sub.l d2,a1
      *move.l a1,d1
      *=16_0881; *=17; !*bclr #17,d1
      *move.l d1,a1
      *subq #1,d0
      *bgt loop
   *clr.l d4
%end

%routine Show Symbol2 (%integer k)
%integer p = addr(font(font(k&255)))+4
   Show Symbol (k)
   xpos = xpos-integer(p)
%end

%routine Show String (%string (255) s)
%integer i
  Show Symbol (Char No (s,i)) %for i = 1,1, Length (s)
%end

!%routine Show Number (%integer N)
!%external %real %fn %spec LOG TEN (%real x)
!%integer p10
!   Show Symbol ('0') %and %return %if N <= 0
!   %if N < 10 %then p10 = 1 %else p10 = 10 ^^ Int Pt (Log Ten (N))
!   %cycle
!      Show Symbol (N//p10 + '0')
!      N = Rem (n,p10)
!      p10 = p10//10
!   %repeat %until p10 = 0
!%end

%routine Frame Message
   Newline; Print String ("WARNING : ");Newline
   Print String ("         This Program needs a Level 1.5 APM");Newline
   Print String ("which supports 32768 colours. You are using");Newline
   Print String ("a Level 1 APM with only 8 colours, so things");Newline
   Print String ("won't look quite the same. Try the machine in");Newline
   Print String ("the Fred Lab - the room with the prom blowers");Newline
   Newline
%end

%integerfn Whipped Cream
@16_7FFFF %byte Red Hot
@16_7FFFC %byte Who am I
@16_0372E %short Minutely
%constinteger Fish = 5
  Minutely = 0
  %cycle; %repeat %until Who am I & 8 # 0
  Red Hot = Fish
  %cycle; %repeat %until Who am I & 8 # 0
  %cycle
     %result = Minutely %unless Minutely = 0
  %repeat
%end

%routine Set Up
%integer i
%integer z = 0
  %on 0 %start
    APM Level = 0
    Newline
    Print String ("Hey shithead, why not pick an APM with a graphics monitor?")
    Newlines (2)
    %stop
  %finish
  Offset (0,0)
  Disable (0)
  Hi Font = 0
  Font Append = 0
  Set Colour (White)
  %for i = 0, 32, 480 %cycle
     Colour Map (1+i)  = z
     Colour Map (3+i)  = 31
     Colour Map (5+i)  = 31<<5
     Colour Map (7+i)  = 31<<5+31
     Colour Map (9+i)  = 31<<10
     Colour Map (11+i) = 31<<10+31
     Colour Map (13+i) = 31<<10+31<<5
     Colour Map (15+i) = 31<<10+31<<5+31
     Colour Map (17+i) = 31<<10+31<<5+31
     Colour Map (19+i) = 31<<10+31<<5
     Colour Map (21+i) = 31<<10+31
     Colour Map (23+i) = 31<<10
     Colour Map (25+i) = 31<<5+31
     Colour Map (27+i) = 31<<5
     Colour Map (29+i) = 31
     Colour Map (31+i) = z
  %repeat
  Check for Mouse
  %return %if APM Level # 1
  APM Level = 1.5 %if Whipped Cream = 16_37 %or Whipped Cream = 16_12 %c
                  %or Whipped Cream = 16_22 %or Whipped Cream = 16_20 %c
                  %or whipped cream = 16_13 %or whipped cream = 16_19 %c
                  %or whipped cream = 16_46 %or whipped cream = 16_1D %c
                  %or whipped cream = 16_35 %or whipped cream = 16_17 %c
                  %or whipped cream = 16_43 %or whipped cream = 16_51 %c
                  %or whipped cream = 16_25 %or whipped cream = 16_4A
%end

%list