PROGRAM MyHouse_InTheMiddleOfMyStreet
  IMPLICITLY DAFT
  
  CHARACTER(*), PARAMETER :: my_house(13) = [  &
      '            ____                     *  ',  &
      '  oo      _/....\_         oo   oo      ',  &
      '        _/........\_      oo oo         ',  &
      '      _/............\_                  ',  &
      '     /................\      ****       ',  &
      '    /|                |\    *******     ',  &
      '     |                |    *********    ',  &
      '     |  +--+   +---+  |    **********   ',  &
      '    /|  |  |   |   |  |      * /***     ',  &
      '   / |  +--+   |   |  |       \| **     ',  &
      '  /  |         |  *|  |        |/       ',  &
      ' /   |         |   |  |    *   |        ',  &
      '/    +---------+---+--+----|   |        ' ]
  
  CHARACTER(*), PARAMETER :: fore_my_house(13) = [  &
      '            rrrr                     Y  ',  &
      '  KK      rryyyyrr         KK   KK      ',  &
      '        rryyyyyyyyrr      KK KK         ',  &
      '      rryyyyyyyyyyyyrr                  ',  &
      '     ryyyyyyyyyyyyyyyyr      gGGg       ',  &
      '    rw                wr    gGggGgg     ',  &
      '     w                w    gggGggggg    ',  &
      '     w  mmmm   mmmmm  w    gGggGGgGgg   ',  &
      '    Bw  m  m   m   m  w      g Kggg     ',  &
      '   B w  mmmm   m   m  w       KK gg     ',  &
      '  B  w         m  wm  w        KK       ',  &
      ' B   w         m   m  w    w   K        ',  &
      'B    wwwwwwwwwwwwwwwwwwwwwww   K        ' ]
  
  CALL output(my_house, fore_my_house)
CONTAINS
  SUBROUTINE output(chars, fore)
    CHARACTER(*), INTENT(IN) :: chars(:)
    CHARACTER(*), INTENT(IN) :: fore(:)
    INTEGER :: line
    
    IF (SIZE(chars) /= SIZE(fore)) THEN
      ERROR STOP 'chars and fore size mismatch.'
    END IF
    
    DO line = 1, SIZE(chars)
      CALL output_line(chars(line), fore(line))
    END DO
  END SUBROUTINE output
  
  SUBROUTINE output_line(chars, fore)
    USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT
    
    CHARACTER(*), INTENT(IN) :: chars
    CHARACTER(*), INTENT(IN) :: fore
    CHARACTER :: current
    INTEGER :: i
    INTEGER :: ic
    INTEGER :: if
    
    IF ((LEN(fore) /= 1) .AND. (LEN(chars) /= LEN(fore))) THEN
      ERROR STOP 'Line length mismatch to foreground attribute length.'
    END IF
    
    current = ''
    ic = 0
    DO i = 1, LEN(chars)
      if = MIN(i,LEN(fore))
      IF ((fore(if:if) /= '') .AND. (fore(if:if) /= current)) THEN
        IF (i > 1) THEN
          WRITE (OUTPUT_UNIT, "(A)", ADVANCE='NO') chars(ic+1:i-1)
          FLUSH(OUTPUT_UNIT)
          ic = i-1
        END IF
        current = fore(if:if)
        CALL set_attr(current)
      END IF
    END DO
    WRITE (OUTPUT_UNIT, "(A)", ADVANCE='YES') chars(ic+1:i-1)
  END SUBROUTINE output_line
  
  SUBROUTINE set_attr(fore)
    USE IFWIN
    
    TYPE :: cmap
      CHARACTER :: sym
      INTEGER(WORD) :: attr
    END TYPE cmap
    
    TYPE(cmap), PARAMETER :: fore_colours(8) = [  &
        cmap('k', 0),  &
        cmap('r', FOREGROUND_RED),  &
        cmap('g', FOREGROUND_GREEN),  &
        cmap('b', FOREGROUND_BLUE),  &
        cmap('y', IOR(FOREGROUND_RED, FOREGROUND_GREEN)),  &
        cmap('m', IOR(FOREGROUND_RED, FOREGROUND_BLUE)),  &
        cmap('c', IOR(FOREGROUND_BLUE, FOREGROUND_GREEN)),  &
        cmap('w', IOR(  &
            IOR(FOREGROUND_RED, FOREGROUND_BLUE),  &
            FOREGROUND_GREEN )) ]
    
    CHARACTER, INTENT(IN) :: fore
    INTEGER(HANDLE) :: console
    INTEGER :: idx
    INTEGER(KIND(fore_colours%attr)) :: intensity
    CHARACTER :: lcase
    INTEGER(BOOL) :: brc
    
    IF (LGE(fore, 'A') .AND. LLE(fore, 'Z')) THEN
      lcase = ACHAR(IACHAR(fore) - IACHAR('A') + IACHAR('a'))
      intensity = FOREGROUND_INTENSITY
    ELSE
      lcase = fore
      intensity = 0
    END IF
    
    DO idx = 1, SIZE(fore_colours)
      IF (lcase == fore_colours(idx)%sym) EXIT
    END DO
    IF (idx > SIZE(fore_colours)) THEN
      ERROR STOP 'Bad foreground attribute.'
    END IF
    
    console = GetStdHandle(STD_OUTPUT_HANDLE)
    brc = SetConsoleTextAttribute(  &
        console,  &
        IOR(fore_colours(idx)%attr, intensity) )
  END SUBROUTINE set_attr
END PROGRAM MyHouse_InTheMiddleOfMyStreet