grdemo1.for

来自「开放源码的编译器open watcom 1.6.0版的源代码」· FOR 代码 · 共 169 行

        include 'graphapi.fi'

        program grdemo1

        include 'graph.fi'

        integer TextColor, TextColor2, BorderColor
        record /videoconfig/ VC
        common TextColor, TextColor2, BorderColor, VC

        integer width, y

        integer initscreen

        if( initscreen() .eq. 0 )then
            print *, 'No graphics adapter present'
            stop
        endif

        ! draw a border around the screen

        call _setcolor( BorderColor )
        call _rectangle( _GBORDER, 0, 0, VC.numxpixels - 1,
     +                       VC.numypixels - 1 )

        ! sweep text in from top & bottom of screen, gradually increasing
        ! character size as the center of the screen is approached.

        call _setcolor( TextColor )
        width = 0
        y = 5
        do while( y .lt. VC.numypixels / 2 - 10 )
            call drawtext( width, y )
            width = width + 1
            y = y + 5
        enddo

        ! draw text over final positions using a different color index

        call _setcolor( TextColor2 )
        call drawtext( width - 1, y - 5 )

        if( VC.adapter .gt. _MCGA )then
            call fadecolors()
        endif

        ! wait for keyboard input and then reset the screen

        call _settextposition( VC.numtextrows, VC.numtextcols - 18 )
        call _outtext( 'Press Enter key...'//char(0) )
        pause
        call _setvideomode( _DEFAULTMODE )
        end


        subroutine drawtext( width, y )

        include 'graph.fi'

        ! This routine displays the text strings.

        integer TextColor, TextColor2, BorderColor
        record /videoconfig/ VC
        common TextColor, TextColor2, BorderColor, VC

        integer width, y, xc

        xc = VC.numxpixels / 2
        call _setcharsize( width, width * 3 / 4 )
        call _settextalign( _CENTER, _BOTTOM )
        call _grtext( xc, y, 'WATCOM FORTRAN 77'//char(0) )
        call _setcharsize( width, width )
        call _settextalign( _CENTER, _TOP )
        call _grtext( xc, VC.numypixels - y, 'GRAPHICS'//char(0) )
        end


        integer function initscreen()

        include 'graph.fi'

        ! This routine selects the best video mode for a given adapter.

        integer TextColor, TextColor2, BorderColor
        record /videoconfig/ VC
        common TextColor, TextColor2, BorderColor, VC

        call _getvideoconfig( VC )
        select( VC.adapter )
        case( _VGA, _SVGA )
            mode = _VRES16COLOR
        case( _MCGA )
            mode = _MRES256COLOR
        case( _EGA )
            if( VC.monitor .eq. _MONO )then
                mode = _ERESNOCOLOR
            else
                mode = _ERESCOLOR
            endif
        case( _CGA )
            mode = _MRES4COLOR
        case( _HERCULES )
            mode = _HERCMONO
        case default
            initscreen = 0        ! report insufficient hardware
            return
        endselect

        if( _setvideomode( mode ) .eq. 0 )then
            initscreen = 0
            return
        endif
        call _getvideoconfig( VC )
        if( VC.numcolors .lt. 4 )then
            TextColor = 1
            TextColor2 = 1
            BorderColor = 1
        else
            TextColor = 1
            TextColor2 = 3
            BorderColor = 2
        endif
        if( VC.adapter .ge. _MCGA )then
            call newcolors()
        endif
        initscreen = 1
        end


        subroutine newcolors()

        include 'graph.fi'

        ! This routine sets the default colors for the program.

        integer TextColor, TextColor2, BorderColor
        record /videoconfig/ VC
        common TextColor, TextColor2, BorderColor, VC

        call _remappalette( TextColor, '003f0000'x )  ! light blue
        call _remappalette( TextColor2, '003f0000'x ) ! light blue
        call _remappalette( BorderColor, _BLACK  )    ! black
        end


        subroutine fadecolors()

        include 'graph.fi'

        ! This routine gradually fades the background text, brightening
        ! the foreground text and the border at the same time.

        integer TextColor, TextColor2, BorderColor
        record /videoconfig/ VC
        common TextColor, TextColor2, BorderColor, VC

        integer i, red, blue, green, maxc

        maxc = 63   ! 6 color bits
        do i=1, maxc
            red = i
            green = ishl( i, 8 )
            blue = ishl( maxc - i, 16 )
            call _remappalette( TextColor, blue )
            call _remappalette( TextColor2, blue + green )
            call _remappalette( BorderColor, red )
        enddo
        end