|
|
沙发
楼主 |
发表于 2020-7-10 01:11:14
|
只看该作者
第二版: 完整的"Fortran"化
1. INTEGER/LOGICAL: all are "4-BYTE".
2. CHARACTER: NO need C-style "NULL" character (C_NULL_CHAR or CHAR(0)) for ending.
3. Almost calls are SUBROUTINEs
Example-1: hanoi[Fortran] 纯文本查看 复制代码 ! [C source code] [url]http://www.mit.edu/afs.new/sipb.mit.edu/project/ncurses/cron-working/ncurses/test/hanoi.c[/url]
!***************************************************************************
! Copyright (c) 1998-2017,2019 Free Software Foundation, Inc. *
! *
! Permission is hereby granted, free of charge, to any person obtaining a *
! copy of this software and associated documentation files (the *
! "Software"), to deal in the Software without restriction, including *
! without limitation the rights to use, copy, modify, merge, publish, *
! distribute, distribute with modifications, sublicense, and/or sell *
! copies of the Software, and to permit persons to whom the Software is *
! furnished to do so, subject to the following conditions: *
! *
! The above copyright notice and this permission notice shall be included *
! in all copies or substantial portions of the Software. *
! *
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS *
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF *
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. *
! IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, *
! DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR *
! OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR *
! THE USE OR OTHER DEALINGS IN THE SOFTWARE. *
! *
! Except as contained in this notice, the name(s) of the above copyright *
! holders shall not be used in advertising or otherwise to promote the *
! sale, use or other dealings in this Software without prior written *
! authorization. *
!***************************************************************************
!
! Name: Towers of Hanoi.
!
! Desc:
! This is a playable copy of towers of hanoi.
! Its sole purpose is to demonstrate my Amiga Curses package.
! This program should compile on any system that has Curses.
! 'hanoi' will give a manual game with 7 playing pieces.
! 'hanoi n' will give a manual game with n playing pieces.
! 'hanoi n a' will give an auto solved game with n playing pieces.
!
! Author: Simon J Raybould ([email]sie@fulcrum.bt.co.uk[/email]).
! (This version has been slightly modified by the ncurses maintainers.)
!
! Date: 05.Nov.90
!
! $Id: hanoi.c,v 1.40 2019/12/14 23:26:09 tom Exp $
!
PROGRAM hanoi !---> C2F by chiangtp, 2020-02
USE curses
IMPLICIT NONE
INTEGER, PARAMETER :: NPEGS = 3 ! This is not configurable !!
INTEGER, PARAMETER :: MINTILES = 3
INTEGER, PARAMETER :: MAXTILES = 11 ! max 12
INTEGER, PARAMETER :: DEFAULTTILES = 7
INTEGER, PARAMETER :: maxbarlen = 3 + 2*(MAXTILES-1)
INTEGER, PARAMETER :: LEFTPEG = 4 + (maxbarlen/2)
INTEGER, PARAMETER :: MIDPEG = LEFTPEG + (maxbarlen+1)
INTEGER, PARAMETER :: RIGHTPEG = MIDPEG + (maxbarlen+1)
INTEGER, PARAMETER :: TOPLINE = 6
INTEGER, PARAMETER :: BASELINE = TOPLINE + MAXTILES + 1
INTEGER :: STATUSLINE = BASELINE + 4
INTEGER :: NMoves
!-------
INTEGER, PARAMETER :: PegPos(0:NPEGS-1) = (/LEFTPEG, MIDPEG, RIGHTPEG/)
!INTEGER, PARAMETER :: TileColour(0:MAXTILES-1) = &
INTEGER, PARAMETER :: TileColour(0: 12-1) = &
(/COLOR_BLUE & ! 1 -> Length 3
,COLOR_RED & ! 2 -> Length 5
,COLOR_GREEN & ! 3 -> Length 7
,COLOR_MAGENTA & ! 4 -> Length 9
,COLOR_CYAN & ! 5 -> Length 11
,COLOR_YELLOW & ! 6 -> Length 13
,COLOR_BLUE +8& ! 7 -> Length 15
,COLOR_RED +8& ! 8 -> Length 17
,COLOR_GREEN +8& ! 9 -> Length 19
,COLOR_MAGENTA+8& ! 10 -> Length 21
,COLOR_CYAN +8& ! 11 -> Length 23
,COLOR_YELLOW +8& ! 12 -> Length 25
/)
TYPE :: PegInfo
INTEGER :: Length(0:MAXTILES-1)
INTEGER :: Count
END TYPE PegInfo
TYPE(PegInfo) :: Pegs(0:NPEGS-1)
!-------
INTEGER :: iarg, narg
CHARACTER(8) :: copt
LOGICAL :: d_option, AutoFlag
INTEGER :: NTiles
INTEGER :: FromCol, ToCol, i, bg, ierr
CHARACTER(256) :: string
!-------------------------------------
! Get the number of arguments passed on the command line
narg = COMMAND_ARGUMENT_COUNT()
! Default setting
d_option = .FALSE.
AutoFlag = .FALSE.
NTiles = DEFAULTTILES
! Parse arguments
iarg = 1
DO WHILE( iarg <= narg )
CALL GET_COMMAND_ARGUMENT(iarg, VALUE=copt)
SELECT CASE( copt )
CASE('-d', '-D'); d_option = .TRUE.
CASE('-a', '-A'); AutoFlag = .TRUE.
CASE('-n', '-N')
iarg = iarg+1
IF( iarg <= narg ) THEN
CALL GET_COMMAND_ARGUMENT(iarg, VALUE=copt)
READ(copt,'(I8)') NTiles
ELSE
CALL usage_stop()
END IF
CASE DEFAULT
CALL usage_stop()
END SELECT
iarg = iarg+1
END DO
IF( NTiles>MAXTILES .OR. NTiles<MINTILES ) THEN
WRITE(*,'(1X,A,I0,A,I0)') "Range ", MINTILES, " to ", MAXTILES
CALL usage_stop()
END IF
!-------------------------------------
CALL initscr() ! same as CALL initscr(stdscr)
IF( has_colors() ) THEN
bg = COLOR_BLACK
CALL start_color()
CALL use_default_colors(ierr)
IF( d_option .AND. (ierr == OK) ) bg = -1
DO i = 0, MAXTILES-1
CALL init_pair(i+1, bg, TileColour(i))
END DO
END IF
CALL cbreak()
IF( LINES < 24 ) THEN
CALL endwin()
WRITE(*,*) "Min screen length 24 lines"
STOP 'EXIT_FAILURE'
END IF
IF( AutoFlag ) THEN
CALL curs_set(0)
CALL leaveok(stdscr, .TRUE.) ! Attempt to remove cursor
END IF
NMoves = 0
!-----------------
CALL InitTiles()
CALL DisplayTiles()
IF( AutoFlag ) THEN
DO
CALL noecho()
CALL AutoMove(0, 2, NTiles)
IF( Solved(NTiles) ) EXIT
END DO
CALL napms(2000)
ELSE
CALL echo()
DO
IF( GetMove(FromCol, ToCol) ) EXIT
IF( InvalidMove(FromCol, ToCol) ) THEN
CALL mvaddstr(STATUSLINE, 0, "Invalid Move, any key to continue ... ")
CALL beep()
CALL anykey()
CALL refresh()
CYCLE
END IF
CALL MakeMove(FromCol, ToCol)
IF( Solved(NTiles) ) THEN
!CALL MvPrintw(STATUSLINE, 0, "Well Done !! You did it in %d moves"//C_NULL_CHAR, NMoves)
WRITE(string,'(A,I0,A)') "Well Done !! You did it in ", NMoves, " moves"
CALL mvaddstr(STATUSLINE, 0, TRIM(string))
CALL refresh()
CALL napms(5)
EXIT
END IF
END DO
END IF
CALL endwin()
CONTAINS !------------------------------
SUBROUTINE usage_stop()
WRITE(*,*)
WRITE(*,*) "Usage: hanoi [options]"
WRITE(*,*) ""
WRITE(*,*) "Options:"
WRITE(*,*) " -d invoke use_default_colors"
WRITE(*,*) " -n NUM set number of tiles (range 3 to 9)"
WRITE(*,*) " -a solve automatically"
WRITE(*,*)
STOP 'EXIT_FAILURE'
END SUBROUTINE usage_stop
!-------------------------------------
SUBROUTINE InitTiles()
IMPLICIT NONE
INTEGER :: Size, SlotNo
!---------------
SlotNo = 0
DO Size = NTiles*2+1, 3, -2
Pegs(0)%Length(SlotNo) = Size
SlotNo = SlotNo + 1
END DO
Pegs(0)%Count = NTiles
Pegs(1)%Count = 0
Pegs(2)%Count = 0
END SUBROUTINE InitTiles
!-------------------------------------
SUBROUTINE DisplayTiles()
USE curses
IMPLICIT NONE
INTEGER, PARAMETER :: BUFSIZ=80
CHARACTER(LEN=BUFSIZ) :: TileBuf
INTEGER :: Line, peg, SlotNo, len, y, x
CHARACTER(80) :: string
!---------------
CALL erase()
string = "T O W E R S O F H A N O I"
y = 1
x = MIDPEG - LEN_TRIM(string)/2
CALL mvaddstr(y, x, TRIM(string))
string = "SJR 1990"
y = 3
x = MIDPEG - LEN_TRIM(string)/2
CALL mvaddstr(y, x, TRIM(string))
WRITE(TileBuf,'(A,I0,A,I0)') "Moves :", NMoves, " of ", (2**NTiles)-1
y = BASELINE+2
x = LEFTPEG-(maxbarlen/2)-2
CALL mvaddstr(y, x, TRIM(TileBuf))
CALL attrset(A_REVERSE)
y = BASELINE
len = (RIGHTPEG+(maxbarlen/2)+2) - x + 1
CALL mvaddstr(y, x, REPEAT(" ", len))
DO Line = TOPLINE, BASELINE-1
CALL mvaddch(Line, LEFTPEG , ' ')
CALL mvaddch(Line, MIDPEG , ' ')
CALL mvaddch(Line, RIGHTPEG, ' ')
END DO
CALL mvaddch(BASELINE, LEFTPEG , '1')
CALL mvaddch(BASELINE, MIDPEG , '2')
CALL mvaddch(BASELINE, RIGHTPEG, '3')
CALL attrset(A_NORMAL)
! Draw tiles
DO peg = 0, NPEGS-1
DO SlotNo = 0, Pegs(peg)%Count-1
len = Pegs(peg)%Length(SlotNo)
!IF( len<BUFSIZ .AND. len<=PegPos(peg) ) THEN
IF( has_colors() ) THEN
!CALL attrset(IOR(COLOR_PAIR(LENTOIND(len)), 0)) !---> LENTOIND(len) = (((int)(len)-1)/2)
CALL attrset(IOR(COLOR_PAIR((len-1)/2) , 0))
ELSE
CALL attrset(A_REVERSE)
END IF
TileBuf = ' '
CALL mvaddstr(BASELINE-(SlotNo+1), (PegPos(peg)-len/2), TileBuf(1:len))
!CALL anykey()
!END IF
END DO
END DO
CALL attrset(A_NORMAL)
CALL refresh()
END SUBROUTINE DisplayTiles
!-------------------------------------
FUNCTION GetMove(From, To)
USE curses
IMPLICIT NONE
INTEGER, INTENT(OUT) :: From, To
LOGICAL :: GetMove
!---------------
GetMove = .TRUE.
CALL mvaddstr(STATUSLINE, 0, "Next move ('q' to quit) from ")
CALL clrtoeol()
CALL refresh()
!-----
CALL getch(From)
IF( From==ICHAR('q') .OR. From==ICHAR('Q') .OR. From==27 ) RETURN
From = From - (ICHAR('0')+1)
CALL addstr(" to ")
CALL clrtoeol()
CALL refresh()
!-----
CALL getch(To)
IF( To==ICHAR('q') .OR. To==ICHAR('Q') .OR. To==27 ) RETURN
To = To - (ICHAR('0')+1)
CALL refresh()
!-----
CALL napms(500)
CALL move(STATUSLINE, 0)
CALL clrtoeol()
CALL refresh()
GetMove = .FALSE.
END FUNCTION GetMove
!-------------------------------------
FUNCTION InvalidMove(From, To)
IMPLICIT NONE
INTEGER, INTENT(IN) :: From, To
LOGICAL :: InvalidMove
!---------------
InvalidMove = .TRUE.
IF( From < 0 ) RETURN
IF( To < 0 ) RETURN
IF( From >= NPEGS ) RETURN
IF( To >= NPEGS ) RETURN
IF( From == To ) RETURN
IF( Pegs(From)%Count == 0 ) RETURN
!IF( (Pegs(To)%Count /= 0) .AND. (Pegs(From)%Length(Pegs(From)%Count-1) > Pegs(To)%Length(Pegs(To)%Count-1)) ) RETURN !---> bug?
!---> chiangtp, 2020-02-09
IF( Pegs(From)%Count>0 .AND. Pegs(To)%Count>0 ) THEN
IF( (Pegs(From)%Length(Pegs(From)%Count-1) >&
Pegs(To )%Length(Pegs(To )%Count-1)) ) RETURN
END IF
!-----
InvalidMove = .FALSE.
END FUNCTION InvalidMove
!-------------------------------------
SUBROUTINE MakeMove(From, To)
IMPLICIT NONE
INTEGER, INTENT(IN) :: From, To
!---------------
Pegs(From)%Count = Pegs(From)%Count - 1
Pegs(To)%Length(Pegs(To)%Count) = Pegs(From)%Length(Pegs(From)%Count)
Pegs(To)%Count = Pegs(To)%Count + 1
NMoves = NMoves + 1
CALL DisplayTiles()
END SUBROUTINE MakeMove
!-------------------------------------
RECURSIVE SUBROUTINE AutoMove(From, To, Num)
USE curses
IMPLICIT NONE
INTEGER, INTENT(IN) :: From, To, Num
!---------------
IF( Num == 1 ) THEN
CALL MakeMove(From, To)
CALL napms(500)
ELSE
!CALL AutoMove(From, OTHER(From,To), Num - 1)
CALL AutoMove(From, 3-(From+To), Num - 1)
CALL MakeMove(From, To)
CALL napms(500)
!CALL AutoMove(OTHER(From,To), To, Num - 1)
CALL AutoMove( 3-(From+To), To, Num - 1)
END IF
END SUBROUTINE AutoMove ! OTHER(From,To) = (3 - (From+To))
!-------------------------------------
FUNCTION Solved(NumTiles)
IMPLICIT NONE
INTEGER, INTENT(IN) :: NumTiles
LOGICAL :: Solved
INTEGER :: i
!---------------
Solved = .TRUE.
DO i = 1, NPEGS-1
IF( Pegs(i)%Count == NumTiles ) RETURN
END DO
Solved = .FALSE.
END FUNCTION Solved
END PROGRAM hanoi
附圖:
Example-2: worm
[Fortran] 纯文本查看 复制代码 !------------------------------------------------------------------------
! [C source code] [url]https://github.com/coreboot/coreboot/blob/master/payloads/libpayload/curses/PDCurses/demos/worm.c[/url]
!------------------------------------------------------------------------
!
! 'Q', 'q', Esc - quit
!
! 'R', 'r' - resize/restore screen size
!
! 'S', 's' - delay mode
! SpaceBar - nodelay mode
!
!------------------------------------------------------------------------
! Copyright (c) 2005 Free Software Foundation, Inc.
!
! Permission is hereby granted, free of charge, to any person obtaining a
! copy of this software and associated documentation files (the
! "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish,
! distribute, distribute with modifications, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included
! in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
! DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
! OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
! THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!
! Except as contained in this notice, the name(s) of the above copyright
! holders shall not be used in advertising or otherwise to promote the
! sale, use or other dealings in this Software without prior written
! authorization.
!------------------------------------------------------------------------
PROGRAM ncurses_worm ! C2F by chiangtp, 2020-01-23
USE curses
IMPLICIT NONE
INTEGER, PARAMETER :: FLAVORS = 7
INTEGER :: flavor(0:FLAVORS-1) = ICHAR([ 'O', '*', '#', '$', '%', '0', '@' ])
INTEGER, PARAMETER :: xinc(0:7) = [ 1, 1, 1, 0,-1,-1,-1, 0 ]
INTEGER, PARAMETER :: yinc(0:7) = [-1, 0, 1, 1, 1, 0,-1,-1 ]
!-------
TYPE :: options
INTEGER :: nopts
INTEGER :: opts(0:2)
END TYPE options
TYPE(options), PARAMETER :: normal(0:7) = [options(3,[7,0,1]), options(3,[0,1,2]), options(3,[1,2,3]), options(3,[2,3,4]),&
options(3,[3,4,5]), options(3,[4,5,6]), options(3,[5,6,7]), options(3,[6,7,0])]
TYPE(options), PARAMETER :: upper(0:7) = [options(1,[1,0,0]), options(2,[1,2,0]), options(0,[0,0,0]), options(0,[0,0,0]),&
options(0,[0,0,0]), options(2,[4,5,0]), options(1,[5,0,0]), options(2,[1,5,0])]
TYPE(options), PARAMETER :: left(0:7) = [options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0]), options(2,[2,3,0]),&
options(1,[3,0,0]), options(2,[3,7,0]), options(1,[7,0,0]), options(2,[7,0,0])]
TYPE(options), PARAMETER :: right(0:7) = [options(1,[7,0,0]), options(2,[3,7,0]), options(1,[3,0,0]), options(2,[3,4,0]),&
options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0]), options(2,[6,7,0])]
TYPE(options), PARAMETER :: lower(0:7) = [options(0,[0,0,0]), options(2,[0,1,0]), options(1,[1,0,0]), options(2,[1,5,0]),&
options(1,[5,0,0]), options(2,[5,6,0]), options(0,[0,0,0]), options(0,[0,0,0])]
TYPE(options), PARAMETER :: upleft(0:7) = [options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0]),&
options(0,[0,0,0]), options(1,[3,0,0]), options(2,[1,3,0]), options(1,[1,0,0])]
TYPE(options), PARAMETER :: upright(0:7) = [options(2,[3,5,0]), options(1,[3,0,0]), options(0,[0,0,0]), options(0,[0,0,0]),&
options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0]), options(1,[5,0,0])]
TYPE(options), PARAMETER :: lowleft(0:7) = [options(3,[7,0,1]), options(0,[0,0,0]), options(0,[0,0,0]), options(1,[1,0,0]),&
options(2,[1,7,0]), options(1,[7,0,0]), options(0,[0,0,0]), options(0,[0,0,0])]
TYPE(options), PARAMETER :: lowright(0:7) = [options(0,[0,0,0]), options(1,[7,0,0]), options(2,[5,7,0]), options(1,[5,0,0]),&
options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0]), options(0,[0,0,0])]
TYPE(options) :: op_a, op_b, op_c, op
!-------
INTEGER, PARAMETER :: max_length=1024
INTEGER, PARAMETER :: max_number=40
TYPE :: wormtype
INTEGER :: orientation, head
INTEGER, ALLOCATABLE :: xpos(:), ypos(:)
END TYPE wormtype
TYPE(wormtype), POINTER :: w
TYPE(wormtype), TARGET :: worm(0:max_number-1)
!-------
INTEGER, ALLOCATABLE :: refyx(:,:)
INTEGER :: bg
INTEGER :: x, y, n, h, i, ch, x1, y1, last, bottom
! Options
CHARACTER(4) :: field
INTEGER :: length
INTEGER :: number
INTEGER :: trail
INTEGER :: iarg, narg
CHARACTER(8) :: copt
INTEGER :: resize=0
!-------------------------------------
! Options:
!
! -f fill screen with copies of 'WORM' at start.
! -l <n> set worm length
! -n <n> set number of worms
! -t make worms leave droppings
!-------------------------------------
! Get the number of arguments passed on the command line
narg = COMMAND_ARGUMENT_COUNT()
! Default setting
field = " " ! fill screen with copies of 'WORM' at start.
length = 16 ! set worm length
number = 3 ! set number of worms
trail = ICHAR(' ') ! make worms leave droppings
! Parse arguments
iarg = 1
DO WHILE( iarg <= narg )
CALL GET_COMMAND_ARGUMENT(iarg, VALUE=copt)
SELECT CASE( copt )
CASE('-f', '-F'); field = "WORM"
CASE('-t', '-T'); trail = ICHAR('.')
CASE('-l', '-L')
iarg = iarg+1
IF( iarg <= narg ) THEN
CALL GET_COMMAND_ARGUMENT(iarg, VALUE=copt)
READ(copt,'(I8)') length
IF( length<2 .OR. length>max_length ) THEN
WRITE(*,'(A,I0)') "Error: Invalid length of worms - ", length
CALL usage()
STOP
END IF
ELSE
CALL usage()
STOP
END IF
CASE('-n', '-N')
iarg = iarg+1
IF( iarg <= narg ) THEN
CALL GET_COMMAND_ARGUMENT(iarg, VALUE=copt)
READ(copt,'(I8)') number
IF( number<1 .OR. number>max_number ) THEN
WRITE(*,'(A,I0)') "Error: Invalid number of worms - ", number
CALL usage()
STOP
END IF
ELSE
CALL usage()
STOP
END IF
CASE DEFAULT
CALL usage()
STOP
END SELECT
iarg = iarg+1
END DO
!-------------------------------------
CALL RANDOM_SEED()
CALL initscr() ! same as: CALL initscr(stdscr)
CALL noecho()
CALL cbreak()
CALL nonl()
CALL keypad(stdscr, .TRUE.)
CALL curs_set(0)
IF( has_colors() ) THEN
CALL start_color()
bg = COLOR_BLACK
!IF( use_default_colors() == OK ) bg = -1
CALL SET_COLOR(0, bg, COLOR_GREEN )
CALL SET_COLOR(1, bg, COLOR_RED )
CALL SET_COLOR(2, bg, COLOR_CYAN )
CALL SET_COLOR(3, bg, COLOR_WHITE )
CALL SET_COLOR(4, bg, COLOR_MAGENTA)
CALL SET_COLOR(5, bg, COLOR_BLUE )
CALL SET_COLOR(6, bg, COLOR_YELLOW )
END IF
!-----------------
1000 CONTINUE
!-----------------
bottom = LINES-1
last = COLS-1
ALLOCATE( refyx(0:LINES-1,0:COLS-1) )
refyx = 0
!refyx(bottom,last) = 1 !---> if addressing the lower right corner doesn't work in your curses
DO n = number-1, 0, -1
worm(n)%orientation = 0
worm(n)%head = 0
ALLOCATE( worm(n)%xpos(0:length-1), worm(n)%ypos(0:length-1) )
worm(n)%xpos = -1
worm(n)%ypos = -1
END DO
! fill screen with copies of "WORM"
IF( field /= ' ' ) THEN
i = 0
!DO y = bottom-1, 0, -1 !---> ???
DO y = bottom , 0, -1
DO x = COLS-1, 0, -1
i = i + 1
CALL addch(field(i:i))
IF( i == LEN_TRIM(field) ) i = 0
END DO
END DO
END IF
CALL napms(12)
CALL refresh()
CALL nodelay(stdscr, .TRUE.)
!-----------------
DO
CALL getch(ch)
IF( ch > 0 ) THEN
SELECT CASE( ch )
CASE( ICHAR('q'), ICHAR('Q'), 27 ) !---> 27 meanse Esc
CALL cleanup()
STOP 'EXIT_SUCCESS'
CASE( ICHAR('s'), ICHAR('S') )
CALL nodelay(stdscr, .FALSE.)
CASE( ICHAR(' ') )
CALL nodelay(stdscr, .TRUE.)
! Resize/Restore the state of the terminal modes, chiangtp, 2020-01-23
CASE( ICHAR('r'), ICHAR('R') )
IF( resize == 0 ) THEN
CALL savetty() ! save the state of the terminal modes
y = 5*jrand(2, 4)
x = 5*jrand(2,15)
CALL resize_term(y, x) ! resize the screen to the given size
resize = 1
ELSE
CALL resetty() ! restore the state of the terminal modes
resize = 0
END IF
!CALL getmaxyx(stdscr,LINES,COLS)
CALL erase()
DEALLOCATE( refyx )
DO n = number-1, 0, -1
DEALLOCATE( worm(n)%xpos )
DEALLOCATE( worm(n)%ypos )
END DO
GO TO 1000
END SELECT
END IF
!---------------
DO n = 0, number-1
w => worm(n)
h = w%head
x = w%xpos(h)
IF( x < 0 ) THEN
w%ypos(h) = bottom
w%xpos(h) = 0
y = w%ypos(h)
x = w%xpos(h)
CALL move(y, x)
CALL addch(flavor(MOD(n,FLAVORS)))
refyx(y,x) = refyx(y,x) + 1
ELSE
y = w%ypos(h)
END IF
IF( x > last ) x = last
IF( y > bottom ) y = bottom
h = h+1
IF( h == length ) h = 0
w%head = h
IF( w%xpos(h) >= 0 ) THEN
x1 = w%xpos(h)
y1 = w%ypos(h)
refyx(y1,x1) = refyx(y1,x1) - 1
IF( y1<LINES .AND. x1<COLS .AND. refyx(y1,x1)==0 ) THEN
CALL move(y1, x1)
CALL addch(trail)
END IF
END IF
!---
IF( y == bottom ) THEN
op_a = lowleft (w%orientation)
op_b = lowright(w%orientation)
op_c = lower (w%orientation)
ELSE IF( y == 0 ) THEN
op_a = upleft (w%orientation)
op_b = upright (w%orientation)
op_c = upper (w%orientation)
ELSE
op_a = left (w%orientation)
op_b = right (w%orientation)
op_c = normal (w%orientation)
END IF
IF( x == last ) THEN
op = op_b
ELSE IF( x == 0 ) THEN
op = op_a
ELSE
op = op_c
END IF
!---
SELECT CASE( op%nopts )
CASE( 0 )
CALL cleanup()
STOP 'EXIT_SUCCESS'
CASE( 1 )
w%orientation = op%opts(0)
CASE DEFAULT
w%orientation = op%opts(jrand(0,op%nopts-1))
END SELECT
y = y + yinc(w%orientation)
x = x + xinc(w%orientation)
CALL move(y, x)
CALL addch(flavor(MOD(n,FLAVORS)))
IF( y < 0 ) y = 0
refyx(y,x) = refyx(y,x) + 1
w%ypos(h) = y
w%xpos(h) = x
END DO
CALL napms(12)
CALL refresh()
END DO
CONTAINS !------------------------------
SUBROUTINE cleanup()
USE curses
IMPLICIT NONE
!---------------
CALL standend()
CALL refresh()
CALL curs_set(1)
CALL endwin()
END SUBROUTINE cleanup
!-------------------------------------
SUBROUTINE SET_COLOR(num, bg, fg)
USE curses
IMPLICIT NONE
INTEGER, INTENT(IN) :: num
INTEGER, INTENT(IN) :: bg, fg
!---------------
CALL init_pair(num+1, fg, bg)
flavor(num) = IOR( IOR(COLOR_PAIR(num+1),A_BOLD), flavor(num) )
END SUBROUTINE SET_COLOR
!-------------------------------------
INTEGER FUNCTION jrand(a, b)
IMPLICIT NONE
INTEGER, INTENT(IN) :: a, b
REAL :: x
!---------------
CALL RANDOM_NUMBER( x )
jrand = a + INT(REAL(b-a+1)*x)
END FUNCTION jrand
!-------------------------------------
SUBROUTINE usage()
WRITE(*,'(A)')
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' @@@ @@@ @@@@@@@@@@ @@@@@@@@@@@ @@@@@@@@@@@@ '
WRITE(*,'(A)') ' @@@ @@@ @@@@@@@@@@@@ @@@@@@@@@@@@ @@@@@@@@@@@@@ '
WRITE(*,'(A)') ' @@@ @@@ @@@@ @@@@ @@@@ @@@@ @@@ @@@@ '
WRITE(*,'(A)') ' @@@ @@ @@@ @@@ @@@ @@@ @@@ @@@ @@@ '
WRITE(*,'(A)') ' @@@ @@@@ @@@ @@@ @@@ @@@ @@@ @@@ @@@ '
WRITE(*,'(A)') ' @@@@ @@@@ @@@@ @@@ @@@ @@@ @@@ @@@ @@@ '
WRITE(*,'(A)') ' @@@@@@@@@@@@ @@@@ @@@@ @@@ @@@ @@@ @@@ '
WRITE(*,'(A)') ' @@@@ @@@@ @@@@@@@@@@@@ @@@ @@@ @@@ @@@ '
WRITE(*,'(A)') ' @@ @@ @@@@@@@@@@ @@@ @@@ @@@ @@@ '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' Eric P. Scott '
WRITE(*,'(A)') ' Caltech High Energy Physics '
WRITE(*,'(A)') ' October, 1980 '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' Color by Eric S. Raymond '
WRITE(*,'(A)') ' July, 1995 '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' Usage: WORM [-f] [-l <n>] [-n <n>] [-t] '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' Options: '
WRITE(*,'(A)') ' -f fill screen with copies of "WORM" at start. '
WRITE(*,'(A)') ' -l <n> set worm length, in the range [2,1024]. '
WRITE(*,'(A)') ' -n <n> set number of worms, in the range [1,40]. '
WRITE(*,'(A)') ' -t make worms leave droppings. '
WRITE(*,'(A)') ' '
WRITE(*,'(A)') ' Example: WORM -f -l 20 -n 5 -t '
WRITE(*,'(A)')
END SUBROUTINE usage
END PROGRAM ncurses_worm
附圖:
Example-3: menu-1
[Fortran] 纯文本查看 复制代码 !----------------------------------------------------------------------
![原文] Introduction to Ncurses: [url]https://www.ibiblio.org/pub/Linux/docs/linux-doc-project/linuxfocus/English/Archives/lf-2002_03-0233.pdf[/url]
![譯作] Ncurses 命令行图形库: [url]https://www.cnblogs.com/wangkangluo1/archive/2012/05/29/2523577.html[/url]
!----------------------------------------------------------------------
PROGRAM menu_reha_2 ! C2F and enchanced by chiangtp, 2020-06
USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR
USE curses
IMPLICIT NONE
INTEGER, PARAMETER :: ENTER=10, ESCAPE=27
INTEGER, PARAMETER :: Wmenu=11 ! width of Menu
INTEGER, PARAMETER :: Nmenu_max=12 ! Number of Menus (<=12, map to F1, ..., F12)
INTEGER, PARAMETER :: Nitem(Nmenu_max) = (/10, 5, 20, 30, 15, 10, 20, 5, 10, 20, 30, 50/)
!TYPE(C_PTR) :: menu_items(0:MAXVAL(Nitem)) ! Absoft not allow
TYPE(C_PTR) :: menu_items(0:100)
TYPE(C_PTR) :: menubar, messagebar
INTEGER :: Nmenu, key, menu, selected_item, i, ii, attrs
CHARACTER(80) :: string
!-------------------------------------
! initialize
CALL initscr() ! same as: CALL initscr(stdscr)
Nmenu = MIN(Nmenu_max, COLS/Wmenu)
! BLACK=0, BLUE=1, GREEN=2, CYAN=3, RED=4, MAGENTA=5, YELLOW=6, WHITE =7
CALL start_color()
ii = 1
DO i = 1, Nmenu
ii = ii + 1
CALL init_pair(i, ii+8, ii) ! "+8" means "high" color
IF( ii == 6 ) ii = 1
END DO
CALL init_pair(Nmenu+1, COLOR_WHITE, COLOR_BLACK) ! selected-item
CALL init_pair(Nmenu+2, COLOR_WHITE, COLOR_BLUE ) ! main window
CALL init_pair(Nmenu+3, COLOR_BLUE , COLOR_WHITE) ! menubar
CALL init_pair(Nmenu+4, COLOR_RED , COLOR_WHITE) ! Funkey numbers
CALL curs_set(0)
CALL noecho()
CALL keypad(stdscr, TRUE)
CALL bkgd(COLOR_PAIR(Nmenu+2))
CALL subwin(stdscr, 1, COLS , 0 , 0, menubar )
CALL subwin(stdscr, 1, COLS-1, LINES-2, 1, messagebar)
!-------
! draw menubar
CALL wbkgd(menubar, COLOR_PAIR(Nmenu+3))
attrs = IOR(COLOR_PAIR(Nmenu+4), A_BOLD)
DO i = 1, Nmenu
CALL wmove(menubar, 0, (i-1)*Wmenu)
WRITE(string,'(I0)') i
CALL waddstr (menubar, "[Menu-")
CALL wattron (menubar, attrs)
CALL waddstr (menubar, TRIM(string))
CALL wattroff(menubar, attrs)
CALL waddstr (menubar, "]")
END DO
WRITE(string,'(A,I0,A)') "Press function key (F1, F2, ... or F", Nmenu, ") to open the menus, ESC quits."
CALL mvaddstr(2, 1, TRIM(string))
CALL refresh()
!-----------------
DO
CALL getch(key)
CALL werase (messagebar)
CALL wrefresh(messagebar)
IF( key == ESCAPE ) THEN
EXIT
ELSE
menu = key - key_F0
IF( menu<1 .OR. menu>Nmenu ) CYCLE
END IF
CALL draw_menu(menu)
CALL scroll_menu(menu, selected_item)
CALL delete_menu()
IF( selected_item < 0 ) THEN
string = "You haven't selected any item."
ELSE
WRITE(string,'(3(A,I0))') "You have selected [menu-", menu, "] item ", selected_item, "."
END IF
CALL waddstr(messagebar, TRIM(string))
CALL touchwin(stdscr)
CALL refresh()
END DO
!-------
CALL delwin(menubar)
CALL delwin(messagebar)
CALL endwin()
CONTAINS !------------------------------
SUBROUTINE draw_menu(menu)
USE curses
IMPLICIT NONE
INTEGER, INTENT(IN) :: menu
INTEGER :: start_col, i
CHARACTER(80) :: string
INTEGER :: maxline
!---------------
maxline = MIN(Nitem(menu), LINES-3)
start_col = (menu-1)*Wmenu
CALL newwin(maxline+2, Wmenu-1, 1, start_col, menu_items(0))
CALL wbkgd(menu_items(0), COLOR_PAIR(menu))
CALL box(menu_items(0), ACS_VLINE, ACS_HLINE)
DO i = 1, maxline
CALL subwin(menu_items(0), 1, Wmenu-3, 1+i, start_col+1, menu_items(i))
WRITE(string,'(A,I0)') "Item ", i
CALL waddstr(menu_items(i), TRIM(string))
END DO
END SUBROUTINE draw_menu
!-------------------------------------
SUBROUTINE delete_menu()
USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_NULL_PTR
USE curses
IMPLICIT NONE
INTEGER :: maxline, i
!---------------
maxline = MIN(Nitem(menu), LINES-3)
DO i = 0, maxline
CALL delwin(menu_items(i))
menu_items(i) = C_NULL_PTR
END DO
END SUBROUTINE delete_menu
!-------------------------------------
RECURSIVE SUBROUTINE scroll_menu(menu, selected)
USE curses
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: menu
INTEGER, INTENT( OUT) :: selected
INTEGER :: selected_save(Nmenu_max)=1, maxline, key
!---------------
! current item
selected = selected_save(menu)
CALL wbkgd(menu_items(selected), COLOR_PAIR(Nmenu+1))
CALL wrefresh(menu_items(0))
maxline = MIN(Nitem(menu), LINES-3)
! Up/Down/Left/Right to select
DO
CALL getch(key)
SELECT CASE( key )
CASE( KEY_HOME, KEY_END )
CALL wbkgd(menu_items(selected), COLOR_PAIR(menu))
CALL wnoutrefresh(menu_items(selected))
selected = MERGE(1, maxline, key==KEY_HOME)
CALL wbkgd(menu_items(selected), COLOR_PAIR(Nmenu+1))
CALL wnoutrefresh(menu_items(selected))
CALL doupdate()
CASE( KEY_DOWN, KEY_UP )
CALL wbkgd(menu_items(selected), COLOR_PAIR(menu))
CALL wnoutrefresh(menu_items(selected))
selected = 1 + MOD(MERGE(selected, selected+maxline-2, key==KEY_DOWN), maxline)
!selected = MERGE(MERGE(maxline, selected-1, selected==1), MERGE(1, selected+1, selected==maxline), key==KEY_UP)
CALL wbkgd(menu_items(selected), COLOR_PAIR(Nmenu+1))
CALL wnoutrefresh(menu_items(selected))
CALL doupdate()
CASE( KEY_LEFT, KEY_RIGHT )
CALL delete_menu()
CALL touchwin(stdscr)
CALL refresh()
selected_save(menu) = selected
menu = 1 + MOD(MERGE(menu, menu+Nmenu-2, key==KEY_RIGHT), Nmenu)
!menu = MERGE(MERGE(Nmenu, menu-1, menu==1), MERGE(1, menu+1, menu==Nmenu), key==KEY_LEFT)
CALL draw_menu(menu)
CALL scroll_menu(menu, selected)
RETURN
CASE( ESCAPE )
selected = -1
RETURN
CASE( ENTER )
selected_save(menu) = selected
RETURN
END SELECT
END DO
END SUBROUTINE scroll_menu
END PROGRAM menu_reha_2
附圖:
Example-4: menu-2
[Fortran] 纯文本查看 复制代码 PROGRAM menu_gpf !---> revised from "SCN-Curses\examples\gpf\nc_simple_menu.f90"
USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR
USE curses
IMPLICIT NONE
INTEGER :: menu_nitem
CHARACTER(80), ALLOCATABLE :: menu_items(:)
INTEGER :: menu_width, menu_height, menu_dx, menu_dy, menu_strlen
TYPE(C_PTR) :: menu_win
!-------
TYPE(MOUSE_EVENT) :: mort
INTEGER :: highlight, choice, key, y, x, i, j
LOGICAL :: within
CHARACTER :: hotkeylist*80, string*80, ckey*12, c1*1
!------------------------------------
menu_nitem = 10
ALLOCATE( menu_items(menu_nitem) )
menu_items( 1) = 'A - Absoft'
menu_items( 2) = ' C - Compaq'
menu_items( 3) = ' I - Intel'
menu_items( 4) = ' L - Lahey'
menu_items( 5) = ' P - PGI'
menu_items( 6) = ' S - Silverfrost'
menu_items( 7) = ' N - NAG'
menu_items( 8) = ' U - GNU'
menu_items( 9) = ' G - G95'
menu_items(10) = ' Q - Quit'
!-------
! left-adjust all menu strings
menu_items = ADJUSTL(menu_items)
! used for length of highlighting-bar
menu_strlen = MAXVAL(LEN_TRIM(menu_items))
! save first letter of choice strings to hotkeylist string
hotkeylist=''
DO i = 1, menu_nitem
c1 = menu_items(i)(1:1)
SELECT CASE( c1 )
CASE( "A":"Z" )
hotkeylist(i:i) = CHAR(ICHAR(c1)+32)
CASE DEFAULT
hotkeylist(i:i) = c1
END SELECT
END DO
!-----------------
! initialize curses(3c), same as: CALL initscr(stdscr)
CALL initscr()
CALL start_color()
CALL init_pair(1, COLOR_WHITE , COLOR_BLUE ) ! menu window
CALL init_pair(2, COLOR_RED +8, COLOR_BLACK) ! warn message
CALL init_pair(3, COLOR_YELLOW+8, COLOR_BLUE ) ! hot-key
CALL clear()
CALL cbreak()
CALL noecho()
CALL curs_set(0)
CALL mousemask(ALL_MOUSE_EVENTS)
!-------
! size of subwindow to create menu in
menu_dy = 1 ! y-spacing
menu_dx = 1 ! x-spacing
menu_height = 2*(menu_dy+1) + menu_nitem ! "+1" means menu-box lines
menu_width = 2*(menu_dx+1) + menu_strlen ! "2*" means left/right or top/button
! start a subwindow for the menu to display in
y = (LINES-menu_height)/2
x = (COLS -menu_width )/2
CALL newwin(menu_height, menu_width, y, x, menu_win)
CALL wbkgd(menu_win,COLOR_PAIR(1))
CALL keypad(menu_win, .TRUE.)
!----------------
highlight = 1
DO
! print usage instructions along the top of the main window
CALL mvaddstr(0, 1, "use arrow keys to go up down, and then, press <Enter> key to select; or")
CALL mvaddstr(1, 1, "[Click Mouse-Button] or [Press Hot-Key] to select ...")
CALL wattron (stdscr, A_REVERSE)
CALL mvaddstr(LINES-1, 1, "Press <Esc> key to end the program")
CALL wattroff(stdscr, A_REVERSE)
! make sure everything is posted to the real screen
CALL refresh()
! draw the menu with the top choice highlighted
CALL print_menu(menu_win, highlight)
!-----
choice = 0
DO
CALL wgetch(menu_win, key)
SELECT CASE( key )
! move highlight choice to Top/Bottom choice
CASE( KEY_HOME, KEY_END )
highlight = MERGE(1, menu_nitem, key==KEY_HOME)
! move highlight choice according to up-arrow being pressed
CASE( KEY_UP )
highlight = MERGE(highlight-1, menu_nitem, highlight/=1)
! move highlight choice according to down-arrow being pressed
CASE( KEY_DOWN )
highlight = MERGE(highlight+1, 1, highlight/=menu_nitem)
! escape
CASE( 27 )
choice = -1
! entered a RETURN so record which choice is highlighted as the selection
CASE( 10 )
choice = highlight
CASE(KEY_MOUSE)
CALL getmouse(mort)
y = mort%y
x = mort%x
CALL wmouse_trafo(menu_win, y, x, .FALSE., within)
IF( .NOT. within ) CYCLE
y = y - menu_dy
IF( y<1 .OR. y>menu_nitem ) CYCLE
x = x - menu_dx
IF( x<1 .OR. x>LEN_TRIM(menu_items(y)) ) CYCLE
highlight = y
CALL print_menu(menu_win, highlight) ! redraw the menu with the highlighting possibly moved
choice = highlight
! for any other key show the key value and (maybe) the character
CASE DEFAULT
j = 0
IF( key>=32 .AND. key<=126 ) THEN ! printable, hot-key
c1 = CHAR(key)
SELECT CASE( c1 )
CASE( "A":"Z" )
c1 = CHAR(ICHAR(c1)+32)
END SELECT
j = INDEX(hotkeylist(1:menu_nitem), c1)
END IF
IF( j>0 .AND. j<=menu_nitem ) THEN
highlight = j
choice = highlight
ELSE
CALL keyname(key, ckey)
IF( ckey=="[" .OR. ckey=="]" ) THEN
WRITE(string,'(A,I0,A)') 'Invalid Hot-Key: Key pressed is code "', key, '" named "'//TRIM(ckey)//'"'
ELSE
WRITE(string,'(A,I0,A)') "Invalid Hot-Key: Key pressed is code [", key, "] named ["//TRIM(ckey)//"]"
END IF
CALL wattron (stdscr, COLOR_PAIR(2))
CALL mvaddstr(LINES-2, 1, TRIM(string))
CALL wattroff(stdscr, COLOR_PAIR(2))
CALL clrtoeol() ! erase the tail of any old message (erases from current position to the end of the current line).
END IF
CALL refresh() ! make sure real screen is up-to-date
END SELECT
! <Esc> pressed to end
IF( choice == -1 ) EXIT
! redraw the menu with the highlighting possibly moved
CALL print_menu(menu_win, highlight)
! User did a choice so come out of the loop
IF( choice /= 0 ) EXIT
END DO
!----------------
! print information on selection made
IF( choice == -1 ) THEN
string = '<Esc> pressed to end the program'
ELSE
WRITE(string,'(A,I0,a)')'You chose choice [', choice, '] with choice string "'//TRIM(menu_items(choice))//'"'
END IF
CALL mvaddstr(LINES-2, 1, TRIM(string))
CALL clrtoeol() ! erase the tail of any old message (erases from current position to the end of the current line).
CALL mvaddstr(LINES-1, 1, 'Any key to continue ...')
CALL clrtoeol() ! erase the tail of any old message (erases from current position to the end of the current line).
CALL refresh()
CALL anykey() ! Wait for a user keystroke. Some terminal types will restore or clear the screen so a pause is a good idea
CALL clear()
IF( choice == -1 ) EXIT
END DO
! exit curses mode
CALL endwin()
DEALLOCATE( menu_items )
CONTAINS !------------------------------
! draw a menu using the list in menu_items(), highlighting one choice
SUBROUTINE print_menu(menu_win, highlight)
USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR
USE curses
IMPLICIT NONE
TYPE(C_PTR), INTENT(IN) :: menu_win
INTEGER, INTENT(IN) :: highlight
INTEGER :: i
!---------------
! outline the subwindow with a box
CALL box(menu_win, 0, 0)
! menu items
DO i = 1, menu_nitem
IF( highlight == i ) CALL wattron (menu_win, A_REVERSE) ! turn on highlighting
CALL mvwaddstr(menu_win, i+menu_dy, 1+menu_dx, menu_items(i)(1:menu_strlen))
IF( highlight == i ) CALL wattroff(menu_win, A_REVERSE) ! turn off highlighting
END DO
! hot-key
CALL wattron (menu_win, COLOR_PAIR(3))
DO i = 1, menu_nitem
IF( highlight == i ) CALL wattron (menu_win, A_REVERSE)
CALL mvwaddstr(menu_win, i+menu_dy, 1+menu_dx, menu_items(i)(1:1))
IF( highlight == i ) CALL wattroff(menu_win, A_REVERSE)
END DO
CALL wattroff(menu_win, COLOR_PAIR(3))
! post everything to the real screen
CALL wrefresh(menu_win)
END SUBROUTINE print_menu
END PROGRAM menu_gpf
體驗, 請下載:
test.rar
(957.54 KB, 下载次数: 1)
|
|
F 币
贡献
权杖
窥视卡
发表于 2020-3-25 21:47:35
微信
收藏
点赞
点踩
提升卡
置顶卡
变色卡
千斤顶
显身卡