module Tree_Walker_m

  ! Walk through the parse tree and generate output

  use ISO_Fortran_Env, only: E => Error_Unit

  use Declaration_Table, only: Decls, Get_Decl
  use Declaration_Types, only: Func, F_Block, F_Dot, F_Line
  use Error_Handler, only: Error_Intro, Simple, Warning
  use Output_m, only: NewLine, Output, OutputOptions
  use Parser_Tables, only: N_Array, N_Glue, N_Stmt
  use String_Table, only: Get_String
  use Toggles, only: Con, Gen, Levels, Toggle
  use Trace, only: Trace_Begin, Trace_End
  use Tree, only: Node_Id, NSons, Source_Ref, Subtree, Sub_Rosa

  implicit NONE
  private
  public :: Tree_Walker

  type :: Block_t
    integer :: Tree
    integer :: X, Y       ! Top left corner, pixels
    integer :: Col, Line  ! Center, page coordinates
    character(2) :: Coord ! Box coordinate 2:6 [A-HJ]
    integer :: I_Coord(2) = 0 ! 2:6, 1:9 [A-HJ]
  end type Block_t

  type :: Dot_t
    integer :: Tree
    integer :: X, Y       ! Center, pixels
    integer :: Col, Line  ! Center, page coordinates
    character(2) :: Coord ! Box coordinate
    integer :: H, V       ! Horz, Vert within Coord
    character(8) :: Label ! d coord _ H _ V
  end type Dot_t

  type :: Line_t
    integer :: Tree
    integer, allocatable :: XY(:,:) ! (x,y) (x,y) ...
    integer, allocatable :: HV(:,:) ! (h,v) (h,v) ...
  end type Line_t

  character, parameter :: E_Block = '#'
  character, parameter :: E_Dot   = 'o'
  character, parameter :: E_Horz  = '-'
  character, parameter :: E_In    = 'a'
  character, parameter :: E_Out   = 'z'
  character, parameter :: E_Vert  = '|'

  type :: What_t
    character :: Id = ' '  ! Empty, Block, Dot, Line
    integer :: N           ! Index in Blocks, Dots, Lines
  end type What_t

  type(block_t), allocatable :: Blocks(:), Temp_Blocks(:)
  type(dot_t),   allocatable :: Dots(:),   Temp_Dots(:)
  type(line_t),  allocatable :: Lines(:),  Temp_Lines(:)

  integer :: N_Block = 0
  integer :: N_Dot = 0
  integer :: N_Line = 0

  character(*), parameter :: Ref = 'BLACK'
  integer :: Ref_Block = 0  ! Reference block, red #ff0000
  integer :: Ref_Line = 0   ! Line through the title line, red #ff0000

  character(9), parameter :: V_Id = 'ABCDEFGHJ'

  type(what_t) :: What(120,198) ! Columns, Lines -- H, V

!---------------------------- RCS Module Info ------------------------------
  character (len=*), private, parameter :: ModuleName= &
       "$RCSfile: Tree_Walker.f90,v $"
  private :: not_used_here 
!---------------------------------------------------------------------------

contains

  subroutine Tree_Walker ( Root, U, Block_Rows, Error )
    integer, intent(in) :: Root   ! Of the abstract syntax tree
    integer, intent(in) :: U      ! Generated output unit number if not zero
                                  ! else the same as the listing file.
    character(8), intent(in) :: Block_Rows ! Rows where there are blocks,
                                           ! for calibrating v_scale
    logical, intent(out) :: Error ! Coordinates out of range

    type(decls) :: Decl
    integer :: GSon       ! Son of son
    real :: H_Scale, V_Scale ! Pixels per character, pixels per line
    integer :: I, J
    integer :: Son        ! Son of Root
    integer :: String     ! String index of label text
    integer :: Sv_Prunit  ! Save outputOptions%prUnit
    character(32) :: Text ! of an argument
    integer :: X2, Y2     ! Second corner of a block

    if ( toggle(con) ) call trace_begin ( 'Type_Walker', text=' for ', node=root )

    error = .false.
    allocate ( blocks(0:100), dots(100), lines(100) )
    sv_prunit = outputOptions%prUnit

    ! Collect fields from the abstract syntax tree into data structures for
    ! blocks, dots, and lines.
    select case ( node_id(root) )
    case ( n_glue )
      do i = 1, nsons(root)
        son = subtree(i,root)
        select case ( node_id(son) )
        case ( n_stmt )
        ! First son is a function name. The rest are arguments
          string = sub_rosa(subtree(1,son))
          decl = get_decl(string,func)
          if ( decl%type == func ) then
            select case ( decl%value )
            case ( f_block )
              if ( levels(gen) > 0 ) call trace_begin ( 'Type_Walker.block', &
                                                      & text=' for ', node=son )
              n_block = n_block + 1
              if ( n_block > ubound(blocks,1) ) then
                allocate ( temp_blocks(0:2*ubound(blocks,1)) )
                temp_blocks(0:ubound(blocks,1)) = blocks
                call move_alloc ( temp_blocks, blocks )
              end if
              blocks(n_block)%tree = son
              call get_string ( sub_rosa(subtree(2,son)), text, & ! Color field
                              & strip=.true., cap=.true. )
              if ( text == ref ) then
                if ( ref_block /= 0 ) then
                  call error_intro ( simple, source_ref(gson) )
                  call output ( 'More than one reference block.', advance='yes' )
                else
                  ref_block = n_block
                end if
              end if
              call get_xy ( son, 4, blocks(n_block)%x, blocks(n_block)%y )
              if ( levels(gen) > 0 ) call trace_end ( 'Type_Walker.block', &
                                                    & text=' for ', node=son )
            case ( f_dot )
              if ( levels(gen) > 0 ) call trace_begin ( 'Type_Walker.dot', &
                                                      & text=' for ', node=son )
              n_dot = n_dot + 1
              if ( n_dot > size(dots) ) then
                allocate ( temp_dots(2*size(dots)) )
                temp_dots(1:size(dots)) = dots
                call move_alloc ( temp_dots, dots )
              end if
              dots(n_dot)%tree = son
              call get_xy ( son, 4, dots(n_dot)%x, dots(n_dot)%y )
              if ( levels(gen) > 0 ) call trace_end ( 'Type_Walker.dot', &
                                                    & text=' for ', node=son )
            case ( f_line )
              if ( levels(gen) > 0 ) call trace_begin ( 'Type_Walker.line', &
                                                      & text=' for ', node=son )
              n_line = n_line + 1
              if ( n_line > size(lines) ) then
                allocate ( temp_lines(2*size(lines)) )
                temp_lines(1:size(lines)) = lines
                call move_alloc ( temp_lines, lines )
              end if
              call get_string ( sub_rosa(subtree(2,son)), text, & ! Color field
                              & strip=.true., cap=.true. )
              if ( text == ref ) then
                if ( ref_line /= 0 ) then
                  call error_intro ( simple, source_ref(gson) )
                  call output ( 'More than one reference line.', advance='yes' )
                else
                  ref_line = n_line
                end if
              end if
              lines(n_line)%tree = son
              gson = subtree(5,son) ! The Array vertex
              allocate ( lines(n_line)%xy(2,nsons(gson)/2) )
              do j = 1, nsons(gson), 2
                call get_xy ( gson, j, lines(n_line)%xy(1,(j-1)/2+1), &
                                     & lines(n_line)%xy(2,(j-1)/2+1) )
              end do
              if ( levels(con) > 0 ) call trace_end ( 'Type_Walker.line', &
                                                    & text=' for ', node=son )
            end select
          end if
        case ( n_array )
        end select
      end do
    end select

    if ( n_block == 0 ) then
      write ( e, '(a)' ) 'There are no logic blocks. Vertical scale cannot be computed.'
      error = .true.
      return
    end if

    h_scale = abs( lines(ref_line)%xy(1,2) - lines(ref_line)%xy(1,1) ) / 119.0
    call get_xy ( blocks(ref_block)%tree, 6, x2, y2 )
    v_scale = abs( blocks(ref_block)%y - y2 ) / 6.0
    if ( toggle(gen) ) then
      write ( text, '(2(a,f0.2))' ) '; H_Scale ', h_scale, ' V_Scale ', v_scale
      call output ( trim(text), advance='yes' )
    end if

    call adjust_v_scale
!    call adjust_h_scale

    ! Generate the output

    what(1:15,5:164:3)%id = e_in
    what(105:119,5:164:3)%id = e_out

    if ( u /= 0 ) outputOptions%prUnit = u
    call gen_blocks
    call gen_dots
write ( 42, '(120a1)' ) what%id
    call gen_lines

    if ( toggle(gen) ) then
      outputOptions%prUnit = sv_prunit
      call output ( ref_block, before='Reference Block ', advance='yes' )
      do i = 1, n_block
        call output ( i, 4, after=': Block Tree ' )
        call output ( blocks(i)%tree )
        call output ( blocks(i)%x, before=' XY (' )
        call output ( blocks(i)%y, before=',', after=')' )
        call output ( blocks(i)%col, before=' CL (' )
        call output ( blocks(i)%line, before=',', after=') Coord ' )
        call output ( blocks(i)%coord )
        call output ( blocks(i)%i_coord(1), before=' IC (' )
        call output ( blocks(i)%i_coord(2), before=',', after=')', advance='yes' )
      end do

      do i = 1, n_dot
        call output ( i, 4, after=': Dot Tree ' )
        call output ( dots(i)%tree )
        call output ( dots(i)%x, before=' XY (' )
        call output ( dots(i)%y, before=',', after=')' )
        call output ( dots(i)%col, before=' CL (' )
        call output ( dots(i)%line, before=',', after=') At ' )
        call output ( dots(i)%coord )
        call output ( dots(i)%h, before='.' )
        call output ( dots(i)%v, before='.', advance='yes' )
      end do

      call output ( ref_line, before='Reference Line ', advance='yes' )
      do i = 1, n_line
        call output ( i, 4, after=': Line Tree ' )
        call output ( lines(i)%tree )
        do j = 1, size(lines(i)%xy,2)
          call output ( lines(i)%xy(1,j), before=' (' )
          call output ( lines(i)%xy(2,j), before=',', after=')' )
        end do
        call newLine
      end do
    end if

    write ( 42, '(120a)' ) what%id

    if ( toggle(con) ) call trace_end ( 'Type_Walker', text=' for ', node=root )

  contains

    subroutine Adjust_H_Scale
      ! Use all logic blocks to compute the horizontal scale. The original
      ! value of h_scale is used only to determine the column number in which a
      ! logic block appears.
      integer :: I, J
      integer :: N_Coord(2:6) ! For each row of blocks
      integer :: P(n_block)   ! Permutation vector to sort the blocks
      integer :: Ranges(6)
      real :: H_Coord(2:6)    ! Average horizontal coordinate (pixels) for 2:6
      real :: H_Scales(3:6)   ! ( Differences between h_coord ) / 17

      ranges = nint( h_scale * [ ( 15 + 17*(i-1), i = 1, 6 ) ] )
      n_coord = 0
      h_coord = 0      
      p = [ ( i, i = 1, n_block ) ]
      ! Sort the blocks according to horizontal pixel coordinate
      do i = 1, n_block
        do j = 2, 6
          if ( blocks(i)%x > ranges(j-1) .and. blocks(i)%x <= ranges(j) ) then
            n_coord(j) = n_coord(j) + 1
            h_coord(j) = h_coord(j) + blocks(i)%x
            exit
          end if
          if ( j > 6 ) then
            write ( e, '(a)' ) 'There are more than 6 horizontal groups of blocks'
            write ( e, '(*(a,i0))' ) 'Block ', p(i), ' at (', blocks(p(i))%x, &
              & ',', blocks(p(i))%y, ')'
            error = .true.
          end if
        end do
      end do
      where ( n_coord > 0 ) h_coord = h_coord / n_coord
      h_scales = 0
      do i = 3, 6
        if ( h_coord(i) == 0 ) cycle
        do j = i-1, 2, -1
          if ( h_coord(j) /= 0 ) then
            h_scales(i-1) = ( h_coord(i) - h_coord(j) ) / ( ( i - j ) * 17 )
            exit
          end if
        end do
      end do
      h_scale = sum(h_scales) / count(h_scales /= 0)
      if ( toggle(gen) ) then
        write ( text, '(2(a,f0.2))' ) '; H_Scale revised ', h_scale, ' S.D. ', &
          sqrt( sum( ( h_scales - h_scale ) **2, &
                       mask=( h_scales /= 0 ) ) / ( count(h_scales /= 0 ) - 1 ) )
        call output ( trim(adjustl(text)), advance='yes' )
      end if
      j = ( blocks(p(1))%x - lines(ref_line)%xy(1,1) ) / h_scale
      blocks(p(1))%i_coord(1) = ( j - 3 ) / 17 + 1
    end subroutine Adjust_H_Scale

    subroutine Adjust_V_Scale
      ! Use all logic blocks to compute the vertical scale. The original
      ! value of v_scale is used only to determine the row number in which a
      ! logic block appears.
      integer :: I, J, K
      integer :: N_Coord(9) ! For each row of blocks
      integer :: P(n_block) ! Permutation vector to sort the blocks
      integer :: T
      real :: V_Coord(9)    ! Average vertical coordinate (pixels) for A-HJ
      real :: V_Scales(8)   ! ( Differences between v_coord ) / 18

      n_coord = 0
      v_coord = 0      
      p = [ ( i, i = 1, n_block ) ]
      ! Sort the blocks according to vertical pixel coordinate
      do i = 1, n_block - 1
        do j = i+1, n_block
          if ( blocks(p(i))%y > blocks(p(j))%y ) then
            t = p(i)
            p(i) = p(j)
            p(j) = t
          end if
        end do
      end do
      j = 1
      n_coord(1) = 1
      v_coord(1) = blocks(p(1))%y
      do i = 2, n_block
        do k = 2, 148, 18
          if ( blocks(p(i))%y - blocks(p(i-1))%y <= k * v_scale ) exit 
          j = j + 1
          if ( j > 9 ) then
            write ( e, '(a)' ) 'There are more than 9 vertical groups of blocks'
            error = .true.
            return
          end if
        end do
        n_coord(j) = n_coord(j) + 1
        v_coord(j) = v_coord(j) + blocks(p(i))%y
        blocks(p(i))%i_coord(2) = j
      end do
      where ( n_coord > 0 ) v_coord = v_coord / n_coord
      v_scales = 0
      do i = 2, 9
        if ( v_coord(i) == 0 ) cycle
        do j = i-1, 1, -1
          if ( v_coord(j) /= 0 ) then
            v_scales(i-1) = ( v_coord(i) - v_coord(j) ) / ( ( i - j ) * 18 )
            exit
          end if
        end do
      end do
      v_scale = sum(v_scales) / count(v_scales /= 0)
      if ( toggle(gen) ) then
        write ( text, '(2(a,f0.2))' ) '; V_Scale revised ', v_scale, ' S.D. ', &
          sqrt( sum( ( v_scales - v_scale ) **2, &
                       mask=( v_scales /= 0 ) ) / ( count(v_scales /= 0 ) - 1 ) )
        call output ( trim(adjustl(text)), advance='yes' )
      end if
      j = ( blocks(p(1))%y - lines(ref_line)%xy(2,1) ) / v_scale
      blocks(p(1))%i_coord(2) = ( j - 3 ) / 18 + 1
      do i = 1, n_block
        call get_page_loc (blocks(i)%x, blocks(i)%y, blocks(i)%col, blocks(i)%line )
        call get_block_coord ( blocks(i)%col, blocks(i)%line, blocks(i)%i_coord, &
                             & blocks(i)%coord )
      end do
    end subroutine Adjust_V_Scale

    subroutine Gen_Blocks
      integer :: C, L    ! Col, Line
      integer :: I, J
      type(block_t) :: T
      ! Calculate Col, Line for each block
      do i = 1, n_block
        c = 7 + 17 * ( iachar(blocks(i)%coord(1:1)) - iachar('1') )
        l = 6 + 18 * min( iachar(blocks(i)%coord(2:2)) - iachar('A'), 9 )
        blocks(i)%col  = c
        blocks(i)%line = l
        what(c-2:c+7,l-2:l+8) = what_t(e_block,i)
      end do
      ! Sort the blocks on their coordinates
      do i = 2, n_block
        do j = 1, n_block-1
          if ( 100 * ( blocks(i)%line - blocks(j)%line ) + &
             & blocks(i)%col - blocks(j)%col < 0 ) then
            t = blocks(i)
            blocks(i) = blocks(j)
            blocks(j) = t
          end if
        end do
      end do
      do i = 1, n_block
        call output ( blocks(i)%coord // ': block,', advance='yes' )
      end do
    end subroutine Gen_Blocks

    subroutine Get_Block_Coord ( Col, Line, I_Coord, Coord )
      integer, intent(in) :: Col, Line
      integer, intent(out) :: I_Coord(2) ! 1..6, 1..9
      character(2), intent(out) :: Coord
      i_coord(1) = min ( ( col - 15 ) / 17 + 2, 6 )
      i_coord(2) = ( line - 3 ) / 18 + 1
      write ( coord, '(i1,a1)' ) i_coord(1), v_id(i_coord(2):i_coord(2))
    end subroutine Get_Block_Coord

    subroutine Gen_Dots
      integer :: H
      integer :: I
      integer :: V          ! Logic block region, 1..9 -> A-HJ
      do i = 1, n_dot
        call get_page_loc (dots(i)%x, dots(i)%y, dots(i)%col, dots(i)%line )
        dots(i)%v = mod( dots(i)%line - 3, 18 ) + 1
        v = ( dots(i)%line - 3 ) / 18 + 1
        dots(i)%coord(2:2) = v_id(v:v)
        h = dots(i)%col - 14
        dots(i)%h = mod ( h, 17 ) + 1
        write ( dots(i)%coord(1:1), '(i1)' ) h / 17 + 1
        write ( dots(i)%label, '(2a,*(a,i0))' ) 'd', dots(i)%coord, &
                                              & '_', dots(i)%h, '_', dots(i)%v
        call output ( trim(dots(i)%label) )
        call output ( ': dot, at=' )
        call output ( dots(i)%coord )
        call output ( dots(i)%h, before='.' )
        call output ( dots(i)%v, before='.', advance='yes' )
        what(dots(i)%col, dots(i)%line) = what_t ( e_dot, i )
      end do
    end subroutine Gen_Dots

    subroutine Gen_Lines
      integer :: I
      character(72) :: From, To
      do i = 1, n_line
        if ( i == ref_line ) cycle
        call get_line_label ( i, 1, from )
        call get_line_label ( i, size(lines(i)%xy,2), to )
        call get_route ( lines(i), to(len_trim(to)+1:) )
        call output ( 'line, from=' )
        call output ( trim(from) )
        call output ( ', to=' )
        call output ( trim(to) )
        if ( size(lines(i)%xy,2) > 2 ) then
        end if
        call newLine
      end do
    end subroutine Gen_Lines

    subroutine Get_Line_Label ( I, J, Label )
      integer, intent(in) :: I     ! Index in Lines
      integer, intent(in) :: J     ! Second subscript of in Lines(i)%xy
      character(*), intent(out) :: Label

      character(2) :: Coord        ! 1..6 [A-HJ]
      integer :: Col, Line
      integer :: H, V              ! W.R.T. I_Coord
      character :: Id              ! What(col,line)%Id
      integer :: I_Coord(2)        ! Block horizontal, vertical coordinates
      integer :: N                 ! What(col,line)%N

      call get_page_loc ( lines(i)%xy(1,j), lines(i)%xy(2,j), col, line )
      call get_block_coord ( col, line, i_coord, coord )
      v = mod(line-3,18)
      id = what(col,line)%id
      if ( id == ' ' ) col = col + 1
      id = what(col,line)%id
      if ( id == ' ' ) col = col - 2
      id = what(col,line)%id
      n = what(col,line)%n
      select case ( id )
      case ( e_in )        ! Input
        write ( label, '(2a1,i1)' ) 'I', coord(2:2), v / 3 + 1
      case ( e_out )       ! Output
        write ( label, '(2a1,i1)' ) 'O', coord(2:2), v / 3 + 1
      case ( e_block )
        h = mod(col-14,17) + 1
        if ( h < 12 ) then ! Input side of a block
          write ( label, '(2a,i0,a)' ) coord, '.', v-2
        else
          write ( label, '(2a,i0,a)' ) coord, '.', v+6
        end if
      case ( e_dot )
        label = dots(n)%label
      case default
        label = ''
        call error_intro ( source_ref(lines(i)%tree), warning )
        call output ( col, before='Beginning or ending of line at (' )
        call output ( line, before=',' )
        call output ( ') is not at a block or dot.', advance='yes' )
      end select
    end subroutine Get_Line_Label

    subroutine Get_Route ( Line, Route )
      type(line_t), intent(in) :: Line
      character(*), intent(out) :: Route
      integer :: CL(size(line%xy,1),size(line%xy,2)) ! (2,n) Coordinates (column, line)
      integer :: I, J, N
      route = ''
      if ( size(cl,2) < 3 ) return
      do i = 1, size(cl,2)
        call get_page_loc ( line%xy(1,i), line%xy(2,i), cl(1,i), cl(2,i) )
      end do
      route(1:1) = '.'
      j = 1
      do i = 2, size(cl,2)
        j = len_trim(route(:j+2)) + 1
        if ( cl(1,i-1) == cl(1,i) ) then      ! Vertical segment
          n = cl(2,i) - cl(2,i-1) + 1
          write ( route(j:j+2), '(a1,i0)' ) merge('U','D',n<0), abs(n)
        else if ( cl(2,i-1) == cl(2,i) ) then ! Horizontal segment
          n = cl(1,i) - cl(1,i-1) + 1
          write ( route(j:j+2), '(a1,i0)' ) merge('R','L',n>0), abs(n)
        else                                  ! Diagonal
          call error_intro ( source_ref(line%tree), warning )
          call output ( cl(1,i-1), before='Line segment from (' )
          call output ( cl(2,i-1), before=',' )
          call output ( cl(1,i), before = ') to (' )
          call output ( cl(2,i), before=',' )
          call output ( ') is diagonal.', advance='yes' )
        end if
      end do
    end subroutine Get_Route

    subroutine Get_Page_Loc ( X, Y, Col, Line )
      integer, intent(in) :: X, Y        ! Pixel positions
      integer, intent(out) :: Col, Line  ! On the page

      col = nint(( x - lines(ref_line)%xy(1,1) - 0.4 * h_scale ) / h_scale)
      line = nint(( y - lines(ref_line)%xy(2,1) - 0.4 * v_scale ) / v_scale)

      col = min(max(col,15),106)
      line = min(max(line,3),164)

    end subroutine Get_Page_Loc

    subroutine Get_XY ( Root, Son, X, Y )
      integer, intent(in) :: Root ! Func node
      integer, intent(in) :: Son  ! Which son of Root is X? Next one is Y
      integer, intent(out) :: X, Y
      character(10) :: Text
      call get_string ( sub_rosa(subtree(son,root)), text )
      read ( text, * ) x
      call get_string ( sub_rosa(subtree(son+1,root)), text )
      read ( text, * ) y
    end subroutine Get_XY

  end subroutine Tree_Walker

!--------------------------- end bloc --------------------------------------
  logical function not_used_here()
  character (len=*), parameter :: IdParm = &
       "$Id: Tree_Walker.f90,v 1.0 2022/03/31 18:57:13 vsnyder Exp $"
  character (len=len(idParm)) :: Id = idParm
    not_used_here = (id(1:1) == ModuleName(1:1))
    print *, Id ! .mod files sometimes change if PRINT is added
  end function not_used_here
!---------------------------------------------------------------------------

end module Tree_Walker_m

! $Log: Tree_Walker.f90,v $
