! testpattern.f90
! Public domain 2007-2010 James Van Buskirk
! Compiled with:
! gfortran -Wall -mwindows -fno-range-check testpattern.f90 -otestpattern -lgdi32
module win32_types
   use ISO_C_BINDING
   implicit none
   private

   public WNDCLASSEX_T
   type, bind(C) :: WNDCLASSEX_T
      integer(C_INT) cbSize
      integer(C_INT) style
      type(C_FUNPTR) lpfnWndProc
      integer(C_INT) cbClsExtra
      integer(C_INT) cbWndExtra
      integer(C_INTPTR_T) hInstance
      integer(C_INTPTR_T) hIcon
      integer(C_INTPTR_T) hCursor
      integer(C_INTPTR_T) hbrBackground
      type(C_PTR) lpszMenuName
      type(C_PTR) lpszClassName
      integer(C_INTPTR_T) hIconSm
   end type WNDCLASSEX_T

   public POINT_T
   type, bind(C) :: POINT_T
      integer(C_LONG) x
      integer(C_LONG) y
   end type POINT_T

   public MSG_T
   type, bind(C) :: MSG_T
      integer(C_INTPTR_T) hwnd
      integer(C_INT) message
      integer(C_INTPTR_T) wParam
      integer(C_INTPTR_T) lParam
      integer(C_LONG) time
      type(POINT_T) pt
   end type MSG_T

   public RECT_T
   type, bind(C) :: RECT_T
      integer(C_LONG) left
      integer(C_LONG) top
      integer(C_LONG) right
      integer(C_LONG) bottom
   end type RECT_T

   public PAINTSTRUCT_T
   type, bind(C) :: PAINTSTRUCT_T
      integer(C_INTPTR_T) hdc
      integer(C_INT) fErase
      type(RECT_T) rcPaint
      integer(C_INT) fRestore
      integer(C_INT) fIncUpdate
      integer(C_INT8_T) rgbReserved(32)
   end type PAINTSTRUCT_T

   public MONITORINFO_T
   type,bind(C) :: MONITORINFO_T
      integer(C_LONG) cbSize
      type(RECT_T) rcMonitor
      type(RECT_T) rcWork
      integer(C_LONG) dwFlags
   end type MONITORINFO_T
end module win32_types

module win32
   use ISO_C_BINDING
   implicit none
   private

   public GetModuleHandle
   interface
      function GetModuleHandle(lpModuleName) &
         bind(C,name='GetModuleHandleA')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetModuleHandle
         integer(C_INTPTR_T) GetModuleHandle
         character(kind=C_CHAR) lpModuleName(*)
      end function GetModuleHandle
   end interface

   public GetCommandLine
   interface
      function GetCommandLine() &
         bind(C,name='GetCommandLineA')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetCommandLine
         type(C_PTR) GetCommandLine
      end function GetCommandLine
   end interface

   public DefWindowProc
   interface
      function DefWindowProc(hwnd, Msg, wParam, lParam) &
         bind(C,name='DefWindowProcA')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: DefWindowProc
         integer(C_LONG) DefWindowProc
         integer(C_INTPTR_T), value :: hwnd
         integer(C_INT), value :: Msg
         integer(C_INTPTR_T), value :: wParam
         integer(C_INTPTR_T), value :: lParam
      end function DefWindowProc
   end interface

   public LoadIcon
   interface
      function LoadIcon(hInstance, lpIconName) &
         bind(C,name='LoadIconA')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: LoadIcon
         integer(C_INTPTR_T) LoadIcon
         integer(C_INTPTR_T), value :: hInstance
         character(kind=C_CHAR) lpIconName(*)
      end function LoadIcon
   end interface

   public LoadCursor
   interface
      function LoadCursor(hInstance, lpCursorName) &
         bind(C,name='LoadCursorA')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: LoadCursor
         integer(C_INTPTR_T) LoadCursor
         integer(C_INTPTR_T), value :: hInstance
         character(kind=C_CHAR) lpCursorName(*)
      end function LoadCursor
   end interface

   public GetStockObject
   interface
      function GetStockObject(fnObject) &
         bind(C,name='GetStockObject')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetStockObject
         integer(C_INTPTR_T) GetStockObject
         integer(C_INT), value :: fnObject
      end function GetStockObject
   end interface

   integer(C_INT), parameter, public :: WHITE_BRUSH = 0 ! Stock object
   integer(C_INT), parameter, public :: BLACK_BRUSH = 4 ! Stock object

   public RegisterClassEx
   interface
      function RegisterClassEx(lpwcx) &
         bind(C,name='RegisterClassExA')

         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: RegisterClassEx
         integer(C_SHORT) RegisterClassEx
         type(WNDCLASSEX_T) lpwcx
      end function RegisterClassEx
   end interface

   public CreateWindowEx
   interface
      function CreateWindowEx(dwExStyle, lpClassName, &
      lpWindowName, dwStyle, x, y, nWidth, nHeight, &
      hwndParent, hMenu, hInstance, lpParam) &
      bind(C,name='CreateWindowExA')

         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: CreateWindowEx
         integer(C_INTPTR_T) CreateWindowEx
         integer(C_LONG), value :: dwExStyle
         character(kind=C_CHAR) lpClassName(*)
         character(kind=C_CHAR) lpWindowName(*)
         integer(C_LONG), value :: dwStyle
         integer(C_INT), value :: x
         integer(C_INT), value :: y
         integer(C_INT), value :: nWidth
         integer(C_INT), value :: nHeight
         integer(C_INTPTR_T), value :: hWndParent
         integer(C_INTPTR_T), value :: hMenu
         integer(C_INTPTR_T), value :: hInstance
         type(C_PTR), value :: lpParam
      end function CreateWindowEx
   end interface

   public ShowWindow
   interface
      function ShowWindow(hWnd,nCmdShow) bind(C,name='ShowWindow')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: ShowWindow
         integer(C_INT) ShowWindow
         integer(C_INTPTR_T), value :: hWnd
         integer(C_INT), value :: nCmdShow
      end function ShowWindow
   end interface

   public UpdateWindow
   interface
      function UpdateWindow(hWnd) bind(C,name='UpdateWindow')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: UpdateWindow
         integer(C_INT) UpdateWindow
         integer(C_INTPTR_T), value :: hWnd
      end function UpdateWindow
   end interface

   public GetMessage
   interface
      function GetMessage(lpMsg,hWnd,wMsgFilterMin,wMsgFilterMax) &
         bind(C,name='GetMessageA')

         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetMessage
         integer(C_INT) GetMessage
         type(MSG_T) lpMsg
         integer(C_INTPTR_T), value :: hWnd
         integer(C_INT), value :: wMsgFilterMin
         integer(C_INT), value :: wMsgFilterMax
      end function GetMessage
   end interface

   public TranslateMessage
   interface
      function TranslateMessage(lpMsg) bind(C,name='TranslateMessage')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: TranslateMessage
         integer(C_INT) TranslateMessage
         type(MSG_T) lpMsg
      end function TranslateMessage
   end interface

   public DispatchMessage
   interface
      function DispatchMessage(lpMsg) bind(C,name='DispatchMessageA')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: DispatchMessage
         integer(C_LONG) DispatchMessage
         type(MSG_T) lpMsg
      end function DispatchMessage
   end interface

   public ExitProcess
   interface
      subroutine ExitProcess(uExitCode) bind(C,name='ExitProcess')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: ExitProcess

         integer(C_INT), value :: uExitCode
      end subroutine ExitProcess
   end interface

   public BeginPaint
   interface
      function BeginPaint(hwnd,lpPaint) bind(C,name='BeginPaint')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: BeginPaint
         integer(C_INTPTR_T) BeginPaint
         integer(C_INTPTR_T), value :: hwnd
         type(PAINTSTRUCT_T) lpPaint
      end function BeginPaint
   end interface

   public GetClientRect
   interface
      function GetClientRect(hwnd,lpRect) bind(C,name='GetClientRect')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetClientRect
         integer(C_INT) GetClientRect
         integer(C_INTPTR_T), value :: hwnd
         type(RECT_T) lpRect
      end function GetClientRect
   end interface

   public DrawText
   interface
      function DrawText(hdc, lpString, nCount, lpRect, &
         uFormat) bind(C,name='DrawTextA')

         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: DrawText
         integer(C_INT) DrawText
         integer(C_INTPTR_T), value :: hdc
         character(kind=C_CHAR) lpString(*)
         integer(C_INT), value :: nCount
         type(RECT_T) lpRect
         integer(C_INT), value :: uFormat
      end function DrawText
   end interface

   public EndPaint
   interface
      function EndPaint(hwnd,lpPaint) bind(C,name='EndPaint')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: EndPaint
         integer(C_INT) EndPaint
         integer(C_INTPTR_T), value :: hwnd
         type(PAINTSTRUCT_T) lpPaint
      end function EndPaint
   end interface

   public PostQuitMessage
   interface
      subroutine PostQuitMessage(nExitCode) bind(C,name='PostQuitMessage')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: PostQuitMessage
         integer(C_INT), value :: nExitCode
      end subroutine PostQuitMessage
   end interface

   public GetLastError
   interface
      function GetLastError() bind(C,name='GetLastError')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetLastError
         integer(C_LONG) GetLastError
      end function GetLastError
   end interface

   public MessageBox
   interface
      function MessageBox(hWnd,lpText,lpCaption,uType) &
         bind(C,name='MessageBoxA')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: MessageBox
         integer(C_INT) MessageBox
         integer(C_INTPTR_T), value :: hWnd
         character(kind=C_CHAR) lpText(*)
         character(kind=C_CHAR) lpCaption(*)
         integer(C_INT), value :: uType
      end function MessageBox
   end interface

   public MoveToEx
   interface
      function MoveToEx(hdc,X,Y,lpPoint) bind(C,name='MoveToEx')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: MoveToEx
         integer(C_INT) MoveToEx
         integer(C_INTPTR_T),value :: hdc
         integer(C_INT), value :: X
         integer(C_INT), value :: Y
         type(POINT_T) lpPoint
      end function MoveToEx
   end interface

   public LineTo
   interface
      function LineTo(hdc,nXEnd,nYEnd) bind(C,name='LineTo')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: LineTo
         integer(C_INT) LineTo
         integer(C_INTPTR_T),value :: hdc
         integer(C_INT), value :: nXEnd
         integer(C_INT), value :: nYEnd
      end function LineTo
   end interface

   public FillRect
   interface
      function FillRect(hdc,lprc,hbr) bind(C,name='FillRect')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: FillRect
         integer(C_INT) FillRect
         integer(C_INTPTR_T),value :: hdc
         type(RECT_T) lprc
         integer(C_INTPTR_T), value :: hbr
      end function FillRect
   end interface

   public DestroyWindow
   interface
      function DestroyWindow(hWnd) bind(C,name='DestroyWindow')
         use ISO_C_BINDING
         implicit none
!GCC$ ATTRIBUTES STDCALL :: DestroyWindow
         integer(C_INT) DestroyWindow
         integer(C_INTPTR_T),value :: hWnd
      end function DestroyWindow
   end interface

   public InvalidateRect
   interface
      function InvalidateRect(hWnd,lpRect,bErase) &
         bind(C,name='InvalidateRect')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: InvalidateRect
         integer(C_INT) InvalidateRect
         integer(C_INTPTR_T),value :: hWnd
         type(RECT_T) lpRect
         integer(C_INT), value :: bErase
      end function InvalidateRect
   end interface

   public MonitorFromPoint
   interface
      function MonitorFromPoint(pt,dwFlags) &
         bind(C,name='MonitorFromPoint')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: MonitorFromPoint
         integer(C_INTPTR_T) MonitorFromPoint
         type(POINT_T), value :: pt
         integer(C_LONG), value :: dwFlags
      end function MonitorFromPoint
   end interface

   public GetMonitorInfo
   interface
      function GetMonitorInfo(hMonitor,lpmi) &
         bind(C,name='GetMonitorInfoA')
         use ISO_C_BINDING
         use win32_types
         implicit none
!GCC$ ATTRIBUTES STDCALL :: GetMonitorInfo
         integer(C_INT) GetMonitorInfo
         integer(C_INTPTR_T), value :: hMonitor
         type(MONITORINFO_T) lpmi
      end function GetMonitorInfo
   end interface
end module win32

module procs
   use win32
   use win32_types
   use ISO_C_BINDING
   implicit none
   private
   public WndProc
   integer mode
   contains
      function WndProc(hwnd, iMsg, wParam, lParam) bind(C)
!GCC$ ATTRIBUTES STDCALL :: WndProc
         integer(C_LONG) WndProc
         integer(C_INTPTR_T), value :: hwnd
         integer(C_INT), value :: iMsg
         integer(C_INTPTR_T), value :: wParam
         integer(C_INTPTR_T), value :: lParam
         integer(C_INTPTR_T) hdc
         type(PAINTSTRUCT_T) ps
         integer(C_INT) result4
         type(RECT_T) rect

         select case(iMsg)
            case(1) ! WM_CREATE
               WndProc = 0
               return
            case(15) ! WM_PAINT
               hdc = BeginPaint(hwnd, ps)
               call PaintContent(hwnd, hdc)
               result4 = EndPaint(hwnd, ps)
               WndProc = 0
               return
            case(2) ! WM_DESTROY
               call PostQuitMessage(0)
               WndProc = 0
               return
            case(792) ! WM_PRINTCLIENT ! Didn't work
               ps%hdc = wParam
               result4 = GetClientRect(hwnd, ps%rcPaint)
               call PaintContent(hwnd, ps%hdc)
               WndProc = 0
               return
            case(256) ! WM_KEYDOWN
               select case(wParam)
                  case(72) ! H
                     mode = 0
                     result4 = GetClientRect(hwnd, rect)
                     result4 = InvalidateRect(hwnd,rect,1)
                     result4 = UpdateWindow(hwnd)
                     WndProc = 0
                     return
                  case(86) ! V
                     mode = 1
                     result4 = GetClientRect(hwnd, rect)
                     result4 = InvalidateRect(hwnd,rect,1)
                     result4 = UpdateWindow(hwnd)
                     WndProc = 0
                     return
                  case(88) ! X
                     result4  = DestroyWindow(hwnd)
               end select
         end select

         WndProc = DefWindowProc(hwnd, iMsg, wParam, lParam)
      end function WndProc

      subroutine PaintContent(hwnd, hdc)
         integer(C_INTPTR_T), value :: hwnd
         integer(C_INTPTR_T), value :: hdc
         type(RECT_T) rect
         character(kind=C_CHAR) message*(80)
         integer(C_INT) result4
         integer(C_INT) i
         integer(C_INT) top
         integer(C_INT) bottom
         type(POINT_T) pt
         integer(C_INTPTR_T) br
         type(RECT_T) current_rect
         integer(C_INT) delta
         integer(C_INT) left
         integer(C_INT) right
         integer(C_INT) uFormat

         result4 = GetClientRect(hwnd, rect)
         delta = int(0.05*(rect%top-rect%bottom))
         br = GetStockObject(BLACK_BRUSH)
         if(mode == 0) then
            bottom = int(rect%bottom+0.25*(rect%top-rect%bottom))
            top = bottom+delta
            do i = rect%left+1,rect%right,2
               result4 = MoveToEx(hdc,i,top,pt)
               result4 = LineTo(hdc,i,bottom)
            end do
            bottom = top
            top = bottom+delta
            do i = rect%left+10,rect%right,20
               current_rect = RECT_T(i,top,i+10,bottom)
               result4 = FillRect(hdc,current_rect,br)
            end do
            bottom = top
            top = bottom+delta
            do i = rect%left+100,rect%right,200
               current_rect = RECT_T(i,top,i+100,bottom)
               result4 = FillRect(hdc,current_rect,br)
            end do
         else if(mode == 1) then
            right = int(rect%right+0.2*(rect%left-rect%right))
            left = right+delta
            do i = rect%bottom-2,rect%top,-2
               result4 = MoveToEx(hdc,left,i,pt)
               result4 = LineTo(hdc,right,i)
            end do
            right = left
            left = right+delta
            do i = rect%bottom-10,rect%top,-20
               current_rect = RECT_T(left,i-10,right,i)
               result4 = FillRect(hdc,current_rect,br)
            end do
            right = left
            left = right+delta
            do i = rect%bottom-100,rect%top,-200
               current_rect = RECT_T(left,i-100,right,i)
               result4 = FillRect(hdc,current_rect,br)
            end do
         end if
         current_rect = rect
         uFormat = 40 ! iany([DT_BOTTOM,DT_LEFT,DT_SINGLELINE])
         current_rect%bottom = int(rect%bottom+0.85*(rect%top-rect%bottom))
         current_rect%left = int(rect%left+0.1*(rect%right-rect%left))
         message = 'Press H for horizontal pattern'//achar(0)
         result4 = DrawText(hdc, message, -1, current_rect, uFormat)
         current_rect%bottom = int(rect%bottom+0.8*(rect%top-rect%bottom))
         message = 'Press V for vertical pattern'//achar(0)
         result4 = DrawText(hdc, message, -1, current_rect, uFormat)
         current_rect%bottom = int(rect%bottom+0.75*(rect%top-rect%bottom))
         message = 'Press X to exit'//achar(0)
         result4 = DrawText(hdc, message, -1, current_rect, uFormat)
      end subroutine PaintContent
end module procs

function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow) &
   bind(C, name='WinMain')
   use win32
   use win32_types
   use procs
   use ISO_C_BINDING
   implicit none
!GCC$ ATTRIBUTES STDCALL :: WinMain
   integer(C_INT) WinMain
   integer(C_INTPTR_T), value :: hInstance
   integer(C_INTPTR_T), value :: hPrevInstance
   type(C_PTR), value :: lpCmdLine
   integer(C_INT), value :: nCmdShow
   character(kind=C_CHAR), pointer :: pcNull(:)
   type(WNDCLASSEX_T) WndClass
   character(kind=C_CHAR), pointer :: cDefault(:)
   character(kind=C_CHAR), target :: szAppName*(80)
   integer(C_SHORT) result2
   integer(C_INTPTR_T) hwnd
   character(kind=C_CHAR), target :: szWindowCaption*(80)
   integer(C_INT) result4
   type(MSG_T) msg
   type(POINT_T) pt
   integer(C_INTPTR_T) hmon
   type(MONITORINFO_T) mi

! use unused dummies
   result4 = int(hprevinstance+ncmdshow,kind(result4))
   nullify(pcNull)
   call C_F_POINTER(lpCmdLine,cDefault,[0])
   szAppName = 'testpattern'//achar(0)
   WndClass%cbSize = int(C_SIZEOF(Wndclass),C_INT)
   WndClass%style = 3 ! ior(CS_HREDRAW, CS_VREDRAW)
   WndClass%lpfnWndProc = C_FUNLOC(WndProc)
   WndClass%cbClsExtra = 0
   WndClass%cbWndExtra = 0
   WndClass%hInstance = hInstance
   call C_F_POINTER(transfer(32512_C_INTPTR_T,C_NULL_PTR), &
      cDefault,[0])
   WndClass%hIcon = LoadIcon(0_C_INTPTR_T, cDefault)
   call C_F_POINTER(transfer(32512_C_INTPTR_T,C_NULL_PTR), &
      cDefault,[0])
   WndClass%hCursor = LoadCursor(0_C_INTPTR_T, cDefault)
   WndClass%hbrBackground = GetStockObject(WHITE_BRUSH)
   WndClass%lpszMenuName = C_NULL_PTR
   WndClass%lpszClassName = C_LOC(szAppName(1:1))
   call C_F_POINTER(transfer(32512_C_INTPTR_T,C_NULL_PTR), &
      cDefault,[0])
   WndClass%hIconSm = LoadIcon(0_C_INTPTR_T, cDefault)

   result2 = RegisterClassEx(WndClass)

   pt = POINT_T(0,0)
   hmon = MonitorFromPoint(pt,1) ! MONITOR_DEFAULTTOPRIMARY
   result4 = GetMonitorInfo(hmon,mi)
   szWindowCaption = 'The Test Pattern'//achar(0)
   hwnd = CreateWindowEx(0_C_LONG, szAppName, szWindowCaption, &
      int(Z'91000000'), mi%rcMonitor%left, mi%rcMonitor%top, &
      mi%rcMonitor%right-mi%rcMonitor%left, &
      mi%rcMonitor%bottom-mi%rcMonitor%top, &
      0_C_INTPTR_T, 0_C_INTPTR_T, hInstance, C_NULL_PTR)

   result4 = ShowWindow(hwnd, 5) ! SW_SHOW
   result4 = UpdateWindow(hwnd)

   do while(GetMessage(msg, 0_C_INTPTR_T, 0, 0) /= 0)
      result4 = TranslateMessage(msg)
      result4 = DispatchMessage(msg)
   end do

   call ExitProcess(int(msg%wParam, C_INT))
   WinMain = 0
end function WinMain