! 
! For an exerice in a Fortran 90 course I made the following two modules
! to draw simple diagrams on a VT100 compatible terminal (i.e. Xterm etc).
! 
! The exercice for the course is:
! 
!   Write a program that simulates the growth of a population with a lot
!   of children per family. 
!   Display the relevant data on your terminal with diagrams.
!   Demonstrate what happens, when family-planing is introduced (only two 
!   kids per femal). How does the population grow in the following 100 years?
!   How will the distribution of old and young people develop? Will there be
!   sufficient man between 28 and 65 years old? etc. etc...
! 
!   The targed of the exercice is array-features, a by-product is a demo
!   of modules.
!   Subroutine plot_integer_array demonstrates an automatic object PILAR,
!   and uses optional arguments when it calls write_string from module
!   vt100_grapgics.
! 
! The participants are programers, which are fluent in Pascal, Modula, C,
! Oberon or FORTRAN77. Most of them will know the basics of object oriented
! programming.

module vt100_graphics   ! Display driver for VT100 terminals
!
! Call INIT_DISPLAY befor calling any other subroutine of this module:
!
!   subroutine init_display
!
!
! Use WRITE_STRING to write on any screen position in inverted or normal mode.
!
!   subroutine write_string (string, line, column, invert)
!     character (*), intent(in)     :: string       !may be zero length
!     integer, intent(in), optional :: line, column !default: same as after last call
!     logical, intent(in), optional :: invert       !default: write normal mode
!
!
! Call FLUSH_DISPLAY to empty internal buffers.
!
!   subroutine flush_display (wait_for_ack) ! flush buffers
!     logical, intent(in) :: wait_for_ack   ! wait for empty input from user? 
!
!
! DISPLAY_LINES and DISPLAY_COLUMNS define screen dimensions.
!
! Author:  gerber@bs.id.ethz.ch       Last modicication date: 17. march 1994
!
implicit none           

private
public init_display, write_string, flush_display       ! procedures
public display_lines, display_columns                  ! variables (constants)

  integer, parameter :: display_lines=24, display_columns=80
  integer :: current_line=0, current_column=0, bufptr = 1
  character (len=display_columns*2) :: buf
  logical :: invert_on = .false.
  character :: up_sequence*5        = char(27)//'[  A', & ! move cursor up
               down_sequence*5      = char(27)//'[  B', & ! move cursor down
               right_sequence*5     = char(27)//'[  C', & ! move cursor right
               left_sequence*5      = char(27)//'[  D', & ! move cursor left
               invertON_sequence*4  = char(27)//'[7m' , & ! invert video on
               invertOFF_sequence*4 = char(27)//'[0m'     ! invert video off
  character (2), parameter :: two_digits(1:80) = &  ! to fill in above sequences
           (/ '01', '02', '03', '04', '05', '06', '07', '08', '09', &
              '10', '11', '12', '13', '14', '15', '16', '17', '18', '19', &
              '20', '21', '22', '23', '24', '25', '26', '27', '28', '29', &
              '30', '31', '32', '33', '34', '35', '36', '37', '38', '39', &
              '40', '41', '42', '43', '44', '45', '46', '47', '48', '49', &
              '50', '51', '52', '53', '54', '55', '56', '57', '58', '59', &
              '60', '61', '62', '63', '64', '65', '66', '67', '68', '69', &
              '70', '71', '72', '73', '74', '75', '76', '77', '78', '79', '80' /)
contains

  subroutine init_display
    integer i    
    write (*, '(a)') invertOFF_sequence
    do i=1,display_lines-1
      write (*, '(a)') ' '
    enddo
    current_line = display_lines; current_column = 1; invert_on = .false.
    bufptr = 1
  end subroutine init_display
  
  subroutine write_string (string, line, column, invert)
  character (*), intent(in)     :: string
  integer, intent(in), optional :: line, column !default: same pos as after last call
  logical, intent(in), optional :: invert       !default: write normal mode
    logical to_invert
    integer ln, col
                                        ! use default values or arguments
    to_invert = .false.
    ln = current_line
    col = current_column
    if (present(invert)) to_invert = invert
    if (present(line)) ln = line
    if (present(column)) col = column
    if (bufptr >= len(buf)-(14+len(string))) then
      call flush_buffer (current_line < display_lines)
    endif
                                         ! cursor line position    
    if (ln > current_line) then
      if (bufptr > 1) call flush_buffer (current_line < display_lines)
      if (ln > current_line) then
        down_sequence(3:4) = two_digits(ln - current_line)
        call put (down_sequence)
        current_line = ln
      endif
    else if (ln < current_line) then
      up_sequence(3:4) = two_digits(current_line - ln)
      call put (up_sequence)
      current_line = ln
    endif
                                         ! cursor column position
    if (col > current_column) then
      right_sequence(3:4) = two_digits(col - current_column)
      call put (right_sequence)
      current_column = col
    else if (col < current_column) then
      left_sequence(3:4) = two_digits(current_column - col)
      call put (left_sequence)
      current_column = col
    endif
                                          ! invert on/off    
    if (to_invert .neqv. invert_on) then
      if (to_invert) then
        call put (invertON_sequence)
      else
        call put (invertOFF_sequence)
      endif
      invert_on = to_invert
    endif
                                          ! write string at current position    
    call put (string)
    current_column = current_column + len(string)
    
    contains
      subroutine put (chars)   ! put some characters into buffer
      character (*) chars      
        buf(bufptr:bufptr+len(chars)-1) = chars
        bufptr = bufptr + len(chars)      
      end subroutine put    
  end subroutine write_string
  
  subroutine flush_display (wait_for_ack) ! flush internal buffer
  logical, intent(in) :: wait_for_ack
    character (1) :: ch
    call write_string ('', display_lines-1, display_columns-2)
    if (bufptr > 1) call flush_buffer (.false.)
    if (wait_for_ack) then   ! wait for empty input from user
      read (*, '(a)') ch
      current_line = current_line + 1; current_column = 1
    endif
  end subroutine flush_display
  
  subroutine flush_buffer (advance) ! flush buffer 
  logical ,intent(in) :: advance    ! change cursor position ?
    if (advance) then
      write (*, '(a)') buf(1:bufptr-1)
      current_line = current_line + 1; current_column = 1
     else
      write (*, '(a)', advance='NO') buf(1:bufptr-1)
   endif
    bufptr = 1
  end subroutine flush_buffer
    
end module vt100_graphics
!--------------------------------------------------------------------------------
module diagrams       ! One to four diagrams on a VT100 Terminal.
!
! You select the number of diagrams on the display with one of the INIT...
! subroutines, which will define the screen layout for you. 
! Title will be displayed on to of the screen. Call just
! one of the following subroutine to initialize the screen layout:
!
!   subroutine init_one_window (title)            ! just one
!     character (*), intent(in) :: title
!   subroutine init_two_high_windows (title)      ! side by side
!     character (*), intent(in) :: title
!   subroutine init_two_large_windows (title)     ! one above the other
!     character (*), intent(in) :: title
!   subroutine init_three_high_windows (title)    ! nr 1 is full screen high
!     character (*), intent(in) :: title
!   subroutine init_three_large_windows (title)   ! nr 1 is full screen large
!     character (*), intent(in) :: title
!   subroutine init_four_windows (title)          ! four
!     character (*), intent(in) :: title
!
!
! Use WRITE_TITLE to write a title in the upper left corner of one window
! and to draw window-borders (to neighbouring windows only):
!
!   subroutine write_title (window, title)
!     integer, intent(in) :: window      ! window number
!     character (*), intent(in) :: title ! not more than 38 characters
!
!
! PLOT_INTEGER_ARRAY draws a diagram from an integer array. Dimension and 
! value-range can be nearly anything. (The sum of all values is limited 
! by the integer limits i.e. +- 2 147 483 647; iarray dimension min=1,
! max=99999):
!
!   subroutine plot_integer_array (window, iarray)
!     integer, intent(in) :: window               ! window number
!     integer, dimension(:), intent(in) :: iarray ! values to draw.
!
!
! SHOW_IT_TO_THE_USER empties internal buffers:
!
!   subroutine show_it_to_the_user (wait_for_ack)
!     logical, intent(in) :: wait_for_ack  ! .true. wait for empty input from user
!
! Author: gerber@bs.id.ethz.ch      Last modification date:  17. march 1994
!
use vt100_graphics
implicit none

 private
 public init_one_window, &
        init_two_high_windows, init_two_large_windows, &
        init_three_high_windows, init_three_large_windows, &
        init_four_windows, &
        write_title, plot_integer_array, show_it_to_the_user

  integer :: lines_of_diagram(4), columns_of_diagram(4), top_line(4), first_column(4)
  integer :: right_border(4), bottom_border(4), bottom_border_length(4)    
  character (display_columns) :: hline, blanks
    
contains

  subroutine init_one_window (title)           ! just one
  character (*), intent(in) :: title
    integer i
    call init_display
    call write_string (title, 1, (display_columns-len(title))/2)
    lines_of_diagram = (/ display_lines-3, 0, 0, 0/)
    columns_of_diagram = (/ display_columns-6, 0, 0, 0 /)
    top_line = (/ 2, 0, 0, 0 /)
    first_column = (/ 1, 0, 0, 0 /)
    right_border = (/ 0, 0, 0, 0 /)
    bottom_border = (/ 0, 0, 0, 0 /)
    bottom_border_length = (/ 0, 0, 0, 0 /)
    do i=1,display_columns
      hline(i:i) = '-'
      blanks(i:i) = ' '
    enddo
  end subroutine init_one_window

  subroutine init_two_high_windows (title)      ! side by side
  character (*), intent(in) :: title
    integer i
    call init_display
    call write_string (title, 1, (display_columns-len(title))/2)
    lines_of_diagram = (/ display_lines-3, display_lines-3, 0, 0/)
    columns_of_diagram = (/ display_columns/2-6, display_columns/2-6, 0, 0 /)
    top_line = (/ 2, 2, 0, 0 /)
    first_column = (/ 1, display_columns/2+1, 0, 0 /)
    right_border = (/ display_columns/2, 0, 0, 0 /)
    bottom_border = (/ 0, 0, 0, 0 /)
    bottom_border_length = (/ 0, 0, 0, 0 /)
    do i=1,display_columns
      hline(i:i) = '-'
      blanks(i:i) = ' '
    enddo
  end subroutine init_two_high_windows

  subroutine init_two_large_windows (title)     ! one above the other
  character (*), intent(in) :: title
    integer i
    call init_display
    call write_string (title, 1, (display_columns-len(title))/2)
    lines_of_diagram = (/ display_lines/2-3, display_lines/2-3,0 ,0/)
    columns_of_diagram = (/ display_columns-6, display_columns-6, 0, 0 /)
    top_line = (/ 2, display_lines/2+2, 0, 0 /)
    first_column = (/ 1, 1, 0, 0 /)
    right_border = (/ 0, 0, 0, 0 /)
    bottom_border = (/ display_lines/2+1, 0, 0, 0 /)
    bottom_border_length = (/ display_columns-1, 0, 0, 0 /)
    do i=1,display_columns
      hline(i:i) = '-'
      blanks(i:i) = ' '
    enddo
  end subroutine init_two_large_windows

  subroutine init_three_high_windows (title)   ! number 1 is full screen high
  character (*), intent(in) :: title
    integer i
    call init_display
    call write_string (title, 1, (display_columns-len(title))/2)
    lines_of_diagram = (/ display_lines-3, display_lines/2-3, &
                        display_lines/2-3 ,0/)
    columns_of_diagram = (/ display_columns/2-6, display_columns/2-6, &
                           display_columns/2-6, 0 /)
    top_line = (/ 2, 2, display_lines/2+2, 0 /)
    first_column = (/ 1, display_columns/2+1, display_columns/2+1, 0 /)
    right_border = (/ display_columns/2, 0, 0, 0 /)
    bottom_border = (/ 0, display_lines/2+1, 0, 0 /)
    bottom_border_length = (/ 0, display_columns/2, 0, 0 /)
    do i=1,display_columns
      hline(i:i) = '-'
      blanks(i:i) = ' '
    enddo
  end subroutine init_three_high_windows

  subroutine init_three_large_windows (title)   ! number 1 is full screen large
  character (*), intent(in) :: title
    integer i
    call init_display
    call write_string (title, 1, (display_columns-len(title))/2)
    lines_of_diagram = (/ display_lines/2-3, display_lines/2-3, &
                        display_lines/2-3 ,0/)
    columns_of_diagram = (/ display_columns-6, display_columns/2-6, &
                           display_columns/2-6, 0 /)
    top_line = (/ 2, display_lines/2+2, display_lines/2+2, 0 /)
    first_column = (/ 1, 1, display_columns/2+1, 0 /)
    right_border = (/ 0, display_columns/2, 0, 0 /)
    bottom_border = (/ display_lines/2+1, 0, 0, 0 /)
    bottom_border_length = (/ display_columns-1, 0, 0, 0 /)
    do i=1,display_columns
      hline(i:i) = '-'
      blanks(i:i) = ' '
    enddo
  end subroutine init_three_large_windows

  subroutine init_four_windows (title)          ! four
  character (*), intent(in) :: title
    integer i
    call init_display
    call write_string (title, 1, (display_columns-len(title))/2)
    lines_of_diagram = display_lines/2 - 3
    columns_of_diagram = display_columns/2 - 6
    top_line = (/ 2, 2, display_lines/2+2, display_lines/2+2 /)
    first_column = (/ 1, display_columns/2+1, 1, display_columns/2+1 /)
    right_border = (/display_columns/2, 0, display_columns/2, 0/)
    bottom_border = (/display_lines/2+1, display_lines/2+1, 0, 0 /)
    bottom_border_length = (/ display_columns/2, display_columns/2, 0, 0 /)
    do i=1,display_columns
      hline(i:i) = '-'
      blanks(i:i) = ' '
    enddo
  end subroutine init_four_windows
  
  subroutine write_title (window, title)         ! and draw window borders
  integer, intent(in) :: window
  character (*), intent(in) :: title ! not more than 38 characters
    integer i    
    call write_string (title, top_line(window), first_column(window))
    if (right_border(window) /= 0) then
      do i=0,lines_of_diagram(window)+1
        call write_string ('|', top_line(window)+i, right_border(window))
      enddo
    endif
    if (bottom_border_length(window) > 0) then
      call write_string (hline(1:bottom_border_length(window)), &
        top_line(window)+lines_of_diagram(window)+2, first_column(window))
    endif
  end subroutine write_title
  
  subroutine show_it_to_the_user (wait_for_ack) ! flush internal buffers
  logical, intent(in) :: wait_for_ack  ! .true. wait for empty input from user
    call flush_display (wait_for_ack)
  end subroutine show_it_to_the_user
  
  subroutine plot_integer_array (window, iarray) ! draw a diagram
  integer, intent(in) :: window                  ! window number
  integer, dimension(:), intent(in) :: iarray    ! values to draw
    integer pilar(columns_of_diagram(window))
    integer pilar_distance, pilar_width, mean_of, i, j, n, maxh, minh
    integer right_shift, zero
    character (3), parameter :: underlines = '___'
    character (10) :: maxlab, minlab
!
!   Pilar width, distance between pilars, both in columns of screen 
!   Number of array-elements per pilar (of which the mean value will be used)
    pilar_width = columns_of_diagram(window) / size(iarray)
    pilar_distance = 0; mean_of = 1
    if (pilar_width == 0) then
      pilar_width = 1
      mean_of = size(iarray) / columns_of_diagram(window) + 1
    else if (pilar_width > 2) then
      pilar_width = min(3, pilar_width-1)
      pilar_distance = 1
    endif
!   Pilar height (still in original values of iarray)
    pilar = 0; n = 0; maxh = 0; minh = iarray(1)
    do i=1, size(iarray), mean_of
      n = n+1
      do j=1,mean_of
        if (i+j-1 > size(iarray)) exit
        pilar(n) = pilar(n) + iarray(i+j-1)
      enddo
      pilar(n) = pilar(n) / (j-1)
      if (pilar(n) > maxh) maxh = pilar(n)
      if (pilar(n) < minh) minh = pilar(n)
    enddo
!   Move the diagram to the right by one column if possible.
    right_shift = 0
    if (columns_of_diagram(window) - n*(pilar_width+pilar_distance) >= 2) &
      right_shift = 1
!   Find nice numbers to be used as tags for y-axis
    minh = label (minh-((maxh-minh)/10), minh, minlab)
    maxh = label (maxh, maxh+((maxh-minh)/10), maxlab)
    if (maxh == minh) then
      maxh = maxh + 1
      minh = minh - 1
    endif
!
!   scale to screen resolution
    do i=1,n
      pilar(i) = (real(lines_of_diagram(window))/real((maxh-minh))) * &
      (pilar(i) - minh)
    enddo
! 
!   Write tag for highest pilar
    call write_string (maxlab(1:5+right_shift), top_line(window)+1, &
    first_column(window))
!   Limit for positive values in screen resolution    
    if (minh >= 0) then
      zero = lines_of_diagram(window)
    else
      zero = lines_of_diagram(window) - &
      (real(lines_of_diagram(window))/real((maxh-minh))) * (0 - minh)
    endif
!
!   Draw pilars (positive values)
    do i=1,zero
      if (i > 1) call write_string (blanks(1:right_shift), &
        top_line(window)+i, first_column(window)+5) ! Positionieren
      do j=1,n
        if ((i == lines_of_diagram(window) .and. pilar(j) == 0) .or. &
        (i/=lines_of_diagram(window) .and. i==zero .and. &
        pilar(j)==lines_of_diagram(window)-zero)) then
          call write_string (underlines(1:pilar_width))    ! Null-Linie    
        else
          call write_string (blanks(1:pilar_width), &
          invert=pilar(j) > lines_of_diagram(window)-i)        ! Saeule
        endif
        if (pilar_distance /= 0) call write_string (blanks(1:pilar_distance))
      enddo
      j = columns_of_diagram(window) - &
          (right_shift + n * (pilar_width + pilar_distance))
      if (j > 0) call write_string (blanks(1:j))  ! Loesche alles dahinter
    enddo
!
!   Continue for negativ values (if any)
    do i=zero+1,lines_of_diagram(window)
      if (i > 1) call write_string (blanks(1:right_shift), &
        top_line(window)+i, first_column(window)+5)  ! Positionieren
      do j=1,n
        call write_string (blanks(1:pilar_width), &
        invert=pilar(j) <= lines_of_diagram(window)-i)        ! Saeule
        if (pilar_distance /= 0) call write_string (blanks(1:pilar_distance))
      enddo
      j = columns_of_diagram(window) - &
          (right_shift + n * (pilar_width + pilar_distance))
      if (j > 0) call write_string (blanks(1:j))  ! Loesche alles dahinter
    enddo
!
!   Write tag for lowest value
    call write_string (minlab(1:5+right_shift), &
      top_line(window)+lines_of_diagram(window), first_column(window))
!
!   Write tag on x-axis useing array-indexes.
    call write_string (blanks(1:columns_of_diagram(window)+5), &
      top_line(window)+lines_of_diagram(window)+1, first_column(window))
    call write_string ('1', column=first_column(window)+5+right_shift)
    write (maxlab, '(i5)') size(iarray)
    call write_string (maxlab(1:5),  &
      column=first_column(window)+right_shift + &
      n*pilar_width + (n-1)*pilar_distance)
    
  contains  
    function label (p_small, p_big, charlab) 
    ! find a nice number between p_small and p_big
    integer                   :: label   ! function value: the nice number
    integer, intent(in)       :: p_small, p_big
    character(*), intent(out) :: charlab ! the same in 5 characters
      character (11) a_small, a_big
      integer i, j, small, big
      logical positiv
      
      positiv = .true.; small = p_small; big = p_big
      ! Special case negative values:
      if (small <= 0) then
        if (big < 0) then          ! we must find a nice negative number.
          positiv = .false.        ! change sign und swap big <-> small
          i = small; small = -big; big = -i
        else                
          label = 0                ! Zero is very nice.
          charlab = '   0 '
          return
        endif
      endif
      ! look for a nice round number between small und big  
      write (a_small,'(i10,1x)') small  ! convert to character-string
      write (a_big,'(i10,1x)') big      
      do i=1,10
        if (a_big(i:i) /= ' ') exit  ! i points to first digit of big
      enddo
      if (a_small(i:i) == ' ') then  ! if small has less decimal digits
        a_big(i:11) = '1 '           ! first digit=1, fill with zeros
        read (a_big, '(bz,i10)') label
      else                           ! same number of digits
        do j=i,10
          if (a_small(j:j) /= a_big(j:j)) exit   ! j points to first difference
        enddo
        do i=j+1,10 ! check if nay digit in small after difference is nonzero
          if (a_small(i:i) /= '0') then                  ! if so:
            a_small(j:10) = char(ichar(a_small(j:j))+1)  ! increment diff-digit 
            exit                                         ! and fill with zeros 
          endif
        enddo
        if (a_small(j:j) == '0') then   ! last digit Zero is nice
          a_small(j+1:11) = ' '
        else if (a_small(j:j) <= '5' .and. a_big(j:j) >= '5') then 
          a_small (j:11) = '5 '         ! Five is nice as well
        else                            ! else just anything in between
          a_small(j:11) = char((ichar(a_small(j:j))+ichar(a_big(j:j)))/2)
        endif
        read (a_small, '(bz,i10)') label     ! convert to integer
      endif
      ! Now write it into five characters        
      if (positiv) then
        if (label < 10000) then
          write (charlab, "(i4,' ')") label
        else if (label < 100000) then
          write (charlab, "(f4.1,'k')") real(label)/1000.0 
        else if (label < 10000000) then
          write (charlab, "(i4,'k')") label/1000
        else if (label < 100000000) then
          write (charlab, "(f4.1,'M')") real(label)/1000000.0
        else
          write (charlab, "(i4,'M')") label/1000000
        endif
      else ! negative
        label = -label
        if (label > -1000) then
          write (charlab, "(i4,' ')") label
        else if (label > -10000) then
          write (charlab, "(f4.1,'k')") real(label)/1000.0 
        else if (label > -1000000) then
          write (charlab, "(i4,'k')") label/1000
        else if (label > -10000000) then
          write (charlab, "(f4.1,'M')") real(label)/1000000.0
        else if (label > -1000000000) then
          write (charlab, "(i4,'M')") label/1000000
        else
          write (charlab, "(f4.1,'G')") real(label)/1000000000.0
        endif         
      endif
    end function label

  end subroutine plot_integer_array
        
end module diagrams
!--------------------------------------------------------------------------------
program demo
use diagrams
implicit none

  call init_three_high_windows ('Three_High')
  call make_three_diagrams
  call init_three_large_windows ('Three Large')
  call make_three_diagrams
contains
  subroutine make_three_diagrams
    integer i
    call write_title (1, 'Window one')
    call write_title (2, 'Window two')
    call write_title (3, 'Window three')
    call plot_integer_array (1, (/ (i,i=1,21) /) )
    call plot_integer_array (2, (/ (i,i=1,1000) /) )
    call plot_integer_array (3, (/ (i,i=100,35100,5000) /) )
    call show_it_to_the_user (.true.)
    call plot_integer_array (1, (/ (i,i=-10,10) /) )
    call plot_integer_array (2, (/ (i,i=20,-10,-1), (i,i=-9,20) /) )
    call plot_integer_array (3, (/ (i,i=-100,-20,10) /) )
    call show_it_to_the_user (.true.)
  end subroutine make_three_diagrams
end program demo