[绘图界面库] Fortran Binding to "Curses (文字視窗的使用者介面)" C-Library

! [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

!------------------------------------------------------------------------
! [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

!----------------------------------------------------------------------
![原文] 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

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