home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 149.lha / ColorTerm / video.4th < prev   
Text File  |  1988-04-25  |  11KB  |  342 lines
  1. \ video.f
  2.  
  3. DECIMAL
  4.  
  5. 320 CONSTANT LWidth
  6. 640 CONSTANT HWidth
  7. 200 CONSTANT LHeight
  8.   4 CONSTANT LDepth                \ 4 bitplanes = 16 colors
  9.  
  10. CREATE ColorTable                  \ Byte values for C64 colors.
  11.  0 C,  0 C,  0 C,   15 C, 15 C, 15 C,   15 C,  0 C,  0 C,
  12.  0 C, 15 C, 15 C,   15 C,  0 C, 15 C,    0 C, 15 C,  0 C,
  13.  0 C,  0 C, 15 C,   15 C, 15 C,  0 C,   15 C,  7 C,  0 C,
  14.  7 C,  3 C,  0 C,   15 C, 10 C, 10 C,    2 C,  2 C,  2 C,
  15. 10 C, 10 C, 10 C,   10 C, 15 C, 10 C,   10 C, 10 C, 15 C,
  16. 13 C, 13 C, 13 C,
  17.  
  18. struct NewScreen ns
  19.   0       ns +nsLeftEdge     W!
  20.   0       ns +nsTopEdge      W!
  21.   LHeight ns +nsHeight       W!
  22.   LDepth  ns +nsDepth        W!
  23.   0       ns +nsDetailPen    C!
  24.   1       ns +nsBlockPen     C!
  25.   0       ns +nsViewModes    W!
  26.   CUSTOMSCREEN SCREENQUIET | ns +nsType W!
  27.   NULL    ns +nsFont         !
  28.   NULL    ns +nsDefaultTitle !
  29.   NULL    ns +nsGadgets      !
  30.   NULL    ns +nsCustomBitMap !
  31. structend
  32.  
  33. struct NewWindow nw
  34.   0       nw +nwLeftEdge                            W!
  35.   0       nw +nwTopEdge                             W!
  36.   LWidth  nw +nwWidth                               W!
  37.   LHeight nw +nwHeight                              W!
  38.   0       nw +nwDetailPen                           C!
  39.   1       nw +nwBlockPen                            C!
  40.   fCLOSEWINDOW MENUPICK | RAWKEY | nw +nwIDCMPFlags !
  41.   ACTIVATE BORDERLESS | WINDOWCLOSE | nw +nwFlags   !
  42.   NULL    nw +nwFirstGadget                         !
  43.   NULL    nw +nwCheckMark                           !
  44.   NULL    nw +nwTitle                               !
  45.   NULL    nw +nwBitMap                              !
  46.   CUSTOMSCREEN nw +nwType                           W!
  47. structend
  48.  
  49. 40 CONSTANT DefaultColumns
  50. 24 CONSTANT LineHeight
  51.  
  52. 32 CONSTANT ASCIISpace
  53.  
  54. CREATE DiskFontLibName  0," diskfont.library"
  55. CREATE UpperFontName    0," C64upper.font"     \ uppercase/graphics font
  56. CREATE LowerFontName    0," C64lower.font"     \ lowercase/uppercase font
  57.  
  58. -1 CONSTANT Up
  59.  1 CONSTANT Down
  60. -1 CONSTANT Left
  61.  1 CONSTANT Right
  62.  
  63.  0 CONSTANT Black
  64.  1 CONSTANT White
  65.  2 CONSTANT Red
  66.  3 CONSTANT Cyan
  67.  4 CONSTANT Purple
  68.  5 CONSTANT Green
  69.  6 CONSTANT Blue
  70.  7 CONSTANT Yellow
  71.  8 CONSTANT Orange
  72.  9 CONSTANT Brown
  73. 10 CONSTANT LightRed
  74. 11 CONSTANT Gray1
  75. 12 CONSTANT Gray2
  76. 13 CONSTANT LightGreen
  77. 14 CONSTANT LightBlue
  78. 15 CONSTANT Gray3
  79.  
  80. struct TextAttr UpperFontAttr
  81. struct TextAttr LowerFontAttr
  82.  
  83. VARIABLE UpperFont         \ Pointer to 64 font.
  84. VARIABLE LowerFont
  85. VARIABLE CurrentFont
  86.  
  87. GLOBAL CursorX             \ location of cursor on screen
  88. GLOBAL CursorY
  89.  
  90. VARIABLE CursorCharacter
  91.  
  92. VARIABLE ColumnWidth
  93. GLOBAL   BaseLine          \ BaseLine of text.
  94.  
  95. GLOBAL   RpBitMap
  96. GLOBAL   SpareBitMap
  97.  
  98. VARIABLE CurrentColor
  99.  
  100. VARIABLE TextBuffer
  101.  
  102. GLOBAL   Inserting?        \ Boolean flag--true if insert mode is on
  103. GLOBAL   Reversed?
  104.  
  105. : OpenDiskFont   ( textattr --- font )
  106.    !A0 CALL.LIB@ 10 5 ;
  107.  
  108. : GetSpareBitMap   ( --- )  \ Allocate and initialize spare BitMap.
  109.    BitMap MEMF_CHIP MEMF_CLEAR | AllocMem  TO SpareBitMap
  110.    SpareBitMap LDepth HWidth LHeight  InitBitMap
  111.    LDepth 0 DO
  112.      HWidth LHeight AllocRaster  SpareBitMap +bmPlanes  I 4* + !
  113.    LOOP ;
  114.  
  115. : FreeSpareBitMap   ( --- )  \ Deallocate spare BitMap.
  116.    LDepth 0 DO
  117.      SpareBitMap +bmPlanes I 4* + @ HWidth LHeight  FreeRaster
  118.    LOOP
  119.    SpareBitMap BitMap FreeMem ;
  120.  
  121. : VPORT   ( --- vport )  \ Return address of current screen's Viewport.
  122.    CurrentScreen @ +scViewPort ;
  123.  
  124. : GetFonts   ( --- )  \ Open custom fonts.
  125.    DiskFontLibName 0 10 OPEN.LIB  DROP
  126.    UpperFontAttr TextAttr ERASE
  127.    UpperFontName UpperFontAttr +taName   !
  128.    8             UpperFontAttr +taYSize  W!
  129.    LowerFontAttr TextAttr ERASE
  130.    LowerFontName LowerFontAttr +taName   !
  131.    8             LowerFontAttr +taYSize  W!
  132.    UpperFontAttr OpenDiskFont  UpperFont !     \ error checking!!!
  133.    LowerFontAttr OpenDiskFont  LowerFont ! ;
  134.  
  135. : CloseFonts   ( --- )  \ Close the custom fonts and diskfontlibrary.
  136.    UpperFont @ CloseFont        \ error checking!!!
  137.    LowerFont @ CloseFont
  138.    10 CLOSE.LIB ;
  139.  
  140. : SetPens   ( apen bpen --- )  \ Set pen colors.
  141.    RPORT SWAP SetBPen  RPORT SWAP SetAPen ;
  142.  
  143. : MakeTextColor   ( color --- )  \ Set text color.
  144.    DUP CurrentColor !
  145.    Black
  146.    Reversed? IF
  147.      SWAP
  148.    THEN
  149.    SetPens ;
  150.  
  151. : SetVidMode   ( f --- )  \ Set normal or reversed mode.
  152.    TO Reversed?
  153.    CurrentColor @ MakeTextColor ;
  154.  
  155. : SetNormal   ( --- )  \ Set normal drawing mode.
  156.    FALSE SetVidMode ;
  157.  
  158. : SetReversed   ( --- )  \ Set inverse drawing mode.
  159.    TRUE SetVidMode ;
  160.  
  161. : ClearScr   ( --- )  \ Clear screen to black.
  162.    0 TO CursorX  0 TO CursorY
  163.    SetNormal
  164.    FALSE TO Inserting?
  165.    RPORT Black SetRast ;
  166.  
  167. : SetNewFont   ( font --- )  \ Switch to different font.
  168.    LOCALS| newfont |
  169.    ClearScr
  170.    RPORT newfont SetFont  DROP
  171.    newfont +tfBaseLine W@ TO BaseLine
  172.    newfont CurrentFont ! ;
  173.  
  174. : SetColors   ( --- )  \ Set screen to C64 colors.
  175.    1 LDepth SCALE 0 DO
  176.      VPORT I
  177.      ColorTable I 3 *    + C@          \ red
  178.      ColorTable I 3 * 1+ + C@          \ green
  179.      ColorTable I 3 * 2+ + C@          \ blue
  180.      SetRGB4
  181.    LOOP ;
  182.  
  183. : SetScreenWidth   ( n --- )  \ Set up screen width.
  184.    DUP 8* ns +nsWidth W!
  185.    DUP 8* nw +nwWidth W!
  186.    DUP 80 = IF
  187.      HIRES ns +nsViewModes W!
  188.    ELSE
  189.      0     ns +nsViewModes W!
  190.    THEN
  191.    1- ColumnWidth !
  192.    ns OpenScreen
  193.    CurrentScreen @ nw +nwScreen !
  194.    nw OpenWindow
  195.    SetColors
  196.    RPORT JAM2 SetDrMd
  197.    ClearScr ;
  198.  
  199. : SwitchRes   ( n menu --- )  \ Switch screen resolution.
  200.    LOCALS| newmenu width |
  201.    CurrentWindow @ ClearMenuStrip
  202.    CurrentWindow @ CloseWindow
  203.    CurrentScreen @ CloseScreen
  204.    width SetScreenWidth
  205.    CurrentFont @ SetNewFont
  206.    CurrentWindow @ newmenu @ SetMenuStrip ;
  207.  
  208. : SetVideo   ( --- )   \ Set up screen.
  209.    DefaultColumns SetScreenWidth
  210.    RPORT +rpBitMap @ TO RpBitMap
  211.    GetSpareBitMap
  212.    Yellow CurrentColor !
  213.    LowerFont @ SetNewFont
  214.    0   TextBuffer      !
  215.    166 CursorCharacter C! ;
  216.  
  217. : LocateText   ( --- )  \ Position graphics cursor to draw text.
  218.    RPORT CursorX 8*  CursorY 8* BaseLine +  Move ;
  219.  
  220. : ToggleCursor   ( --- )  \ Draw cursor at current cursor position.
  221.    LocateText
  222.    RPORT COMPLEMENT SetDrMd
  223.    RPORT CursorCharacter 1 Text DROP
  224.    RPORT JAM2 SetDrMd ;
  225.  
  226. : ScrollScreen   ( --- )  \ Scroll screen upwards one line.
  227.    SpareBitMap RPORT +rpBitMap !
  228.    SpareBitMap CurrentScreen @ +scViewPort +vpRasInfo @ +riBitMap !
  229.    RPORT Black SetRast             \ erase spare BitMap
  230.    RpBitMap 0 8 SpareBitMap 0 0
  231.    CurrentWindow @ +wdWidth W@ LHeight 8- 192 255 NULL  BltBitMap DROP
  232.    CurrentScreen @ MakeScreen      \ show the spare
  233.    RethinkDisplay
  234.    SpareBitMap 0 0 RpBitMap 0 0
  235.    CurrentWindow @ +wdWidth W@ LHeight 192 255 NULL  BltBitMap  DROP
  236.    RpBitMap RPORT +rpBitMap !      \ switch back to the real one
  237.    RpBitMap CurrentScreen @ +scViewport +vpRasInfo @ +riBitmap !
  238.    CurrentScreen @ MakeScreen      \ and display it
  239.    RethinkDisplay ;
  240.  
  241. : CheckCursorLimits   ( --- )  \ Make sure cursor is still on the screen.
  242.    CursorX ColumnWidth @ > IF
  243.      0 TO CursorX  1 CursorY + TO CursorY
  244.    ELSE
  245.      CursorX  0<  IF  ColumnWidth @ TO CursorX  -1 CursorY + TO CursorY  THEN
  246.    THEN
  247.    CursorY 0< IF
  248.      0 TO CursorY
  249.    ELSE
  250.      CursorY LineHeight > IF  LineHeight TO CursorY ScrollScreen  THEN
  251.    THEN ;
  252.  
  253. : MoveHorizontal   ( direction --- )  \ Move cursor horizontally.
  254.    CursorX + TO CursorX  CheckCursorLimits ;
  255.  
  256. : MoveVertical   ( direction --- )  \ Move cursor vertically.
  257.    CursorY + TO CursorY  CheckCursorLimits ;
  258.  
  259. : PrintLF   ( --- )  \ Print a linefeed.
  260.    CursorY 1+ TO CursorY  CheckCursorLimits ;
  261.  
  262. : PrintCR   ( --- )  \ Print a carriage return.
  263.    SetNormal
  264.    FALSE TO Inserting?
  265.    0 TO CursorX  PrintLF ;
  266.  
  267. : HomeCursor   ( --- )  \ Move cursor to home position.
  268.    0 TO CursorX  0 TO CursorY ;
  269.  
  270. : EmitScrChar   ( char --- )  \ Draw a character.
  271.    TextBuffer C!
  272.    LocateText
  273.    RPORT TextBuffer 1 Text DROP
  274.    1 CursorX + TO CursorX  CheckCursorLimits ;
  275.  
  276. : PrintBackSpace   ( --- )  \ Print a backspace.
  277.    -1 CursorX + TO CursorX  CheckCursorLimits
  278.    ASCIISpace EmitScrChar
  279.    -1 CursorX + TO CursorX  CheckCursorLimits ;
  280.  
  281. : MoveChars   ( direction --- )  \ Insert or delete a character.
  282.    8* NEGATE RPORT SWAP 0  CursorX 8*  CursorY 8*
  283.    CurrentWindow @ +wdWidth W@
  284.    CursorY 1+ 8*
  285.    ScrollRaster ;
  286.  
  287. : InsertChar   ( --- )  \ Insert space at cursor position.
  288.    Right MoveChars
  289.    Reversed?
  290.    SetNormal
  291.    ASCIISpace EmitScrChar
  292.    -1 CursorX + TO CursorX  CheckCursorLimits
  293.    IF
  294.      SetReversed
  295.    THEN ;
  296.  
  297. : DeleteChar   ( --- )  \ Delete character at cursor position.
  298.    -1 CursorX + TO CursorX  CheckCursorLimits
  299.    Left MoveChars ;
  300.  
  301. : PrintScrChar   ( char --- )  \ Output a character to the screen.
  302.    LOCALS| char |
  303.    char 161 < IF
  304.      char CASE
  305.        ASCIISpace 127 RANGE.OF  char EmitScrChar             ENDOF
  306.                     5       OF  White MakeTextColor          ENDOF
  307.                     7       OF  CurrentScreen @ DisplayBeep  ENDOF
  308.                     8       OF  PrintBackSpace               ENDOF
  309.                  { 10       OF  PrintLF                      ENDOF }
  310.                    13       OF  PrintCR                      ENDOF
  311.                    14       OF  LowerFont @ SetNewFont       ENDOF
  312.                    17       OF  Down MoveVertical            ENDOF
  313.                    18       OF  SetReversed                  ENDOF
  314.                    19       OF  HomeCursor                   ENDOF
  315.                    20       OF  DeleteChar                   ENDOF
  316.                    28       OF  Red MakeTextColor            ENDOF
  317.                    29       OF  Right MoveHorizontal         ENDOF
  318.                    30       OF  Green  MakeTextColor         ENDOF
  319.                    31       OF  Blue   MakeTextColor         ENDOF
  320.                   129       OF  Orange MakeTextColor         ENDOF
  321.                   142       OF  UpperFont @ SetNewFont       ENDOF
  322.                   144       OF  Black  MakeTextColor         ENDOF   \ ???
  323.                   145       OF  Up MoveVertical              ENDOF
  324.                   146       OF  SetNormal                    ENDOF
  325.                   147       OF  ClearScr                     ENDOF
  326.                   148       OF  InsertChar                   ENDOF
  327.               149 155 RANGE.OF  char 140 - MakeTextColor     ENDOF
  328.                   156       OF  Purple MakeTextColor         ENDOF
  329.                   157       OF  Left MoveHorizontal          ENDOF
  330.                   158       OF  Yellow MakeTextColor         ENDOF
  331.                   159       OF  Cyan   MakeTextColor         ENDOF
  332.                   160       OF  ASCIISpace EmitScrChar       ENDOF
  333.      ENDCASE
  334.    ELSE
  335.      char CASE
  336.        161 191 RANGE.OF  char EmitScrChar  ENDOF
  337.        192 223 RANGE.OF  char 96 - EmitScrChar  ENDOF
  338.        224 254 RANGE.OF  char 64 - EmitScrChar  ENDOF
  339.            255       OF  char EmitScrChar       ENDOF
  340.      ENDCASE
  341.    THEN ;
  342.