best_factor Subroutine

private pure recursive subroutine best_factor(nodes, idx, lit)

This is recursive procedure to tour a given syntax tree.

Arguments

Type IntentOptional Attributes Name
type(tree_node_t), intent(in) :: nodes(:)
integer, intent(in) :: idx
type(literal_t), intent(inout) :: lit

Source Code

   pure recursive subroutine best_factor(nodes, idx, lit)
      implicit none
      type(tree_node_t), intent(in) :: nodes(:)
      integer, intent(in) :: idx
      type(literal_t), intent(inout) :: lit

      type(literal_t) :: lit_l, lit_r
      type(tree_node_t) :: curr
      integer :: i

      curr = nodes(idx)
      curr%c = nodes(idx)%c
      lit%all%c = theta
      lit%pref%c = theta
      lit%suff%c = theta
      lit%fact%c = theta

      if (curr%op == op_union .or. curr%op == op_concat) then
         call best_factor(nodes, curr%left_i, lit_l)
         call best_factor(nodes, curr%right_i, lit_r)
      end if

      select case (curr%op)

      case(op_union)
         lit%pref%c = same_part_of_prefix(lit_l%pref%c, lit_r%pref%c)
         lit%suff%c = same_part_of_suffix(lit_l%suff%c, lit_r%suff%c)
         lit%flag_closure = .true.

      case(op_concat)
! #ifdef IMPURE
! write(0,*) "L103: ", lit_l%flag_class, lit_r%flag_class, lit_l%flag_closure, lit_r%flag_closure
! #endif
         lit%flag_class = lit_l%flag_class .or. lit_r%flag_class
         lit%flag_closure = lit_l%flag_closure .or. lit_r%flag_closure

         select case (return_class_closure(lit_l%flag_class, lit_r%flag_class, lit_l%flag_closure, lit_r%flag_closure))
         case (lt_N_class_N_closure)
            lit%all%c = lit_l%all%c//lit_r%all%c
            lit%pref%c = best(lit_l%pref%c, lit_l%all%c//lit_r%pref%c)
            lit%suff%c = best(lit_r%suff%c, lit_l%suff%c//lit_r%all%c)

         case (lt_N_class_R_closure)
            lit%pref%c = lit_l%all%c//lit_r%pref%c
            lit%suff%c = lit_r%suff%c           

         case (lt_N_class_L_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_l%suff%c//lit_r%all%c

         case (lt_N_class_LR_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c

         ! following 12 cases are not tested enough.
         !===========================================================================!
         case (lt_R_class_N_closure)
            lit%pref%c = best(lit_l%pref%c, lit_l%all%c//lit_r%pref%c)
            lit%suff%c = lit_r%suff%c

         case (lt_R_class_R_closure)
            lit%pref%c = best(lit_l%pref%c, lit_l%all%c//lit_r%pref%c)
            lit%suff%c = lit_r%suff%c

         case (lt_R_class_L_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c
            ! lit%fact%c = best(lit_r%suff%c, lit_l%suff%c//lit_r%all%c)

         case (lt_R_class_LR_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c

         !===========================================================================!
         case (lt_L_class_N_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = best(lit_r%suff%c, lit_l%suff%c//lit_r%all%c)

         case (lt_L_class_R_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c
            continue
         case (lt_L_class_L_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = best(lit_r%suff%c, lit_l%suff%c//lit_r%all%c)
            continue
         case (lt_L_class_LR_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c
            continue
         !===========================================================================!
         case (lt_LR_class_N_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c
            continue
         case (lt_LR_class_R_closure)
            lit%pref%c = lit_l%pref%c
            lit%pref%c = lit_l%pref%c
            continue
         case (lt_LR_class_L_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c
            continue
         case (lt_LR_class_LR_closure)
            lit%pref%c = lit_l%pref%c
            lit%suff%c = lit_r%suff%c
            continue
         end select

         !== Intermediate literals (factors) are not implemented and tested yet.
         ! lit%fact%c = best(best(lit_l%fact%c, lit_r%fact%c), lit_l%suff%c//lit_r%pref%c)

      case (op_closure)
         lit%flag_closure = .true.

      case (op_char)

         if (curr%c%single_flag) then
            lit%all%c = char_utf8(curr%c%first())
            lit%pref%c = char_utf8(curr%c%first())
            lit%suff%c =  char_utf8(curr%c%first())
            lit%fact%c =  char_utf8(curr%c%first())
         else
            lit%flag_class = .true.
         end if

      case (op_repeat)
         block
            type(tree_node_t) :: next_l

            ! Is the flag_class of the next node flagged? 
            call best_factor(nodes, curr%left_i, lit_l)
            lit%flag_class = lit_l%flag_class

            do i = 1, curr%min_repeat       
               call best_factor(nodes, curr%left_i, lit_l)
               lit%all%c = lit%all%c//lit_l%all%c
               lit%pref%c = lit%pref%c//lit_l%pref%c
               lit%suff%c = lit%suff%c//lit_l%suff%c
               lit%fact%c = lit%fact%c//lit_l%fact%c
               lit%flag_class = lit%flag_class .or. lit_l%flag_class
               if (lit_l%flag_closure) exit
            end do

            if (curr%min_repeat /= curr%max_repeat) lit%all%c = ''

            lit%flag_closure = curr%min_repeat /= curr%max_repeat
            lit%flag_closure = lit%flag_closure .or. lit_l%flag_closure
         end block

      case default
         lit%flag_closure = .true.
      end select
   end subroutine best_factor