C     Totally FORTRAN implementation of Precompiler Includes Generator
C     by Barry W. McCleave, PhD, P.E. 601-634-2599
      include 'prefor32.fi'      
C      FORM TEMPLATE
c      itemtype()=I (or i) means integer*2      Int
c      itemtype()=L (or l) means integer*4      Longint
c      itemtype()=R (or r) means real*4         Real
c      itemtype()=D (or d )means real*8         Double Precision
c      itemtype()=C (or c) means string         Characters (termination \)
c      itemtype()=S (or s) choice only          Selection
c      itemtype()=T (or t) comment field        Text
c      itemtype()=H (or h) form title           Heading
c      itemchosen()= the list item selected (0 if edit entry)
c      delimeter=^ after each selection list item; before first list item 
c      delimeter=| at end of every form item
c      delimeter=\ at end of every text line (\\ produces \ if c string)
c      last item followed by 0 (\0 poduces 0 if c string)

      integer*4 function WinMain [stdcall,alias:'_WinMain@16'] 
     1 (hInstance[VALUE], 
     1 hPrevInstance[VALUE],lpszCmdLine[VALUE], nCmdShow[VALUE])      
      include 'prefor32.fd'
      integer*4 hinstance,hprevinstance
      integer*4 lpszcmdline
      integer*4 ncmdshow
      integer*4 initmain 
      integer*4 hwnd,mainmsgloop 
      if(initmain(hinstance,hprevinstance,ncmdshow,hwnd).eq.TRUE) 
     1  WinMain=mainmsgloop(hinstance)
      return
      end

       integer*4 Function Initmain (
     1 hInstance,hPrevInstance,ncmdshow,hwnd)
       include 'prefor32.fd'
       external mainwindowproc
       integer*4 hInstance,hPrevInstance,nCmdShow,hbgbrush
       integer*4 createwindowex,loadcursor,registerclass
      record /wndclass/ windowclass
      integer*4   hWnd,hinst,CreateSolidBrush
      common /edatamain/ hinst,hbgbrush
       integer*4 blue
c      colorref format is #bbggrr    blue green red
       parameter (blue=#7F0000)
c       integer*4 idc_arrow
c       data idc_arrow/32512/
      Initmain = TRUE
      hinst=hinstance
      if (hPrevInstance.eq.false) then
         WindowClass.lpszClassName = locfar('EdatWin'C)
         WindowClass.hInstance     = hInstance
         WindowClass.lpfnWndProc   = locfar(mainwindowproc)
         WindowClass.hCursor       = LoadCursor(null,idc_arrow)
         WindowClass.hIcon         = NULL
         WindowClass.lpszMenuName  = NULL
         hbgbrush = CreateSolidBrush(blue)
         WindowClass.hbrBackground = hbgbrush
         WindowClass.style         = 0
         WindowClass.cbClsExtra    = 0
         WindowClass.cbWndExtra    = 0
         if (RegisterClass (WindowClass).eq.false) Initmain = false
      end if
      hWnd = CreateWindowEx(0,locfar('EdatWin'C),locfar('EDITDATA'C),            
     1 WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,0,CW_USEDEFAULT,0,NULL,               
     1 NULL,hInstance,NULL)           
      call ShowWindow (hWnd,nCmdShow)
      call UpdateWindow(hWnd)
      return 
      end

      integer*4 Function mainMsgLoop(hInstance)
      integer*4 hInstance
       include 'prefor32.fd'
       Record /tagmsg/ msg
       integer*4 GetMessage
      DO WHILE (GetMessage(msg,null,0,0).ne.false)
         Call TranslateMessage(msg)
         Call DispatchMessage(msg)
         mainMsgLoop=msg.wParam
      End Do
      return
      end
      
      Integer*4 Function mainwindowproc [stdcall,
     1 alias:'_MAINWINDOWPROC']
     1 (hWnd[VALUE],wMsgID[VALUE],wParam[VALUE],lParam[VALUE])
      include 'prefor32.fd'
      integer*4 hWnd,wMsgID,wParam,hparent
      Integer*4 lParam,lberr,lselected
      Character*80 TextBuffer 
      integer*4 hinst,hbgbrush 
      common /edatamain/ hinst,hbgbrush
      integer*4 SelectObject,i,nowitem
      integer*4 hWndEdit,GetWindowText,xmax,ymax 
      integer*4 defwindowproc,ws_mybutton
      integer*4 createwindow,setfocus,loword,hiword,destroywindow
      integer*4 SetBkMode,BeginPaint
      integer*4 cxChar,hdc,ierr,TextOut,numread
      integer*4 GetDC,GetTextMetrics,GetStockObject,ReleaseDC
      INTEGER*4 ipreviouscolor,SetTextColor,SetBkColor,GetSysColor
      integer*4 SendMessage
      Record /tagTextMetric/ tm
      Record /tagRect/ rect
      Record /tagPAINTSTRUCT/ ps
      Record /tagLOGPEN/ pen
      logical*1 form,confirmed
      integer*4 hinstance,hprevinstance,hPR
      integer*4 lpszcmdline
      integer*4 ncmdshow
      integer*4 initmain,extent_x,extent_y 
      INTEGER*1 UPARROW,DOWNARROW,LEFTARROW,RIGHTARROW
      CHARACTER*12 FILENAM
      character*13 wintitle
      CHARACTER*1 TYPDAFIL,RFLAG  
       integer*1 IIA,IIE,IIS,IIL,IIR,IID,IIP
      INTEGER*1 IIM,IIX,IIT,IIY,IIN
      integer*4 INFILEPTR
      CHARACTER*80 A
      integer*1 a1(80),b(80),c(80)
      character*12 filefd(20)
      character*12 filefi(20)
      CHARACTER*35 fileform 
      character*7 pound_define
      CHARACTER*30 file_in_h,file_out_def,file_out_fd
      LOGICAL*1 MODIFY_OLD,FLGCONFIRMED,GROUPCONFIRM
      REAL*8 INFROWS(2)
      REAL*8 LINEROWS(1)
      CHARACTER*30 FILEN,file_out_pre
      integer*1 itemchfile(2)
      LOGICAL*1 REDRAW,NONE,GRAPH,RESOLUTION
      integer*4 color(80)
      character*1 image(200000)
      common/bigimage/image
      common/pallet2/bitmapinfo,pal
      Record /tagbitmapfileheader/ bitmapfileheader
      Record /tagbitmapinfoheader/ bitmapinfo
      integer*4 hmemorydc,hbitmap,deletedc
      integer*4 pal(512)
      integer*4 createcompatibledc,createdibitmap,bitblt
      integer*4 hpenbackground,hpenline,cychar
      COMMON/COLORS/hpenbackground,hpenline,cychar
      EQUIVALENCE (INFROWS(1),INFILEPTR)
      equivalence (a,a1(1))
      logical*1 copying,found,hex
      integer*4 hpenblue,hpengreen,hpenyellow,hpenwhite,hpenred,
     1 hpenblack
       integer*4 return,escape,char_fsmall,char_flarge
       integer*4 char_nsmall,char_nlarge,char_lsmall,char_llarge
       integer*4 char_dsmall,char_dlarge,char_usmall,char_ularge
       integer*4 char_asmall,char_alarge,char_psmall,char_plarge
       integer*4 char_hsmall,char_hlarge
       integer*4 char_0,char_1,char_2,char_3,char_4,char_5,char_6
       integer*4 char_7,char_8,char_9,alt,shift
       integer*4 left_arrow,right_arrow,up_arrow,down_arrow
       integer*4 blue,yellow,red,black,white,green,lightblue,purple
       integer*4 idm_next
       integer*1 base_small_letters
       parameter (idm_next=#300)
c      colorref format is #bbggrr    blue green red
       parameter (blue=#7F0000)
       parameter (yellow=#00CFCF)
       parameter (green=#00FF00)
       parameter (red=#0000FF)
       parameter (white=#FFFFFF)
       parameter (black=#0)
       parameter (lightblue=#CFCF00)
       parameter (purple=#CF00CF)
       parameter (return=13)
       parameter (escape=27)
       parameter (alt=#12)
       parameter (shift=#10)
       parameter (right_arrow=#27)
       parameter (left_arrow=#25)
       parameter (up_arrow=#26)
       parameter (down_arrow=#28)
       parameter (char_fsmall=#66)
       parameter (char_flarge=#46)
       parameter (char_hsmall=#68)
       parameter (char_hlarge=#48)
       parameter (char_lsmall=#6c)
       parameter (char_llarge=#4c)
       parameter (char_nsmall=#6e)
       parameter (char_nlarge=#4e)
       parameter (char_psmall=#70)
       parameter (char_plarge=#50)
       parameter (char_usmall=#75)
       parameter (char_ularge=#55)
       parameter (char_dsmall=#64)
       parameter (char_dlarge=#44)
       parameter (char_asmall=#61)
       parameter (char_alarge=#41)
       parameter (char_0=#30)
       parameter (char_1=#31)
       parameter (char_2=#32)
       parameter (char_3=#33)
       parameter (char_4=#34)
       parameter (char_5=#35)
       parameter (char_6=#36)
       parameter (char_7=#37)
       parameter (char_8=#38)
       parameter (char_9=#39)
      integer*4 CreatePenIndirect
      data itemchfile/0,1/
      DATA FILEform/'cProgram Name^OOPS, EXIT PROGRAM^|\0'c/   
      data itemchline/0/
      DATA SPACE/1H /,ZERO/1H0/
      DATA INFCHOS,INFCHOS2,ONE,TWO,MINUS/1,2,1H1,1H2,1H-/  
      DATA IIA/1HA/,
     1 IIS/1HS/,IIY/1HY/,IIN/1HN/,IIP/1HP/
      DATA IIE/1HE/,IIL/1HL/,IIM/1HM/,IID/1HD/,IIR/1HR/,IIX/1HX/,
     1 IIT/1HT/
      data filen/'\0'c/
      data pen.style,pen.x,pen.y,pen.color/PS_SOLID,1,1,YELLOW/
      data base_small_letters/96/
      data filefd/'USER32.FD   ','GDI32.FD    ','KERNEL32.FD ',
     1'COMDLG32.FD ','COMCTL32.FD ','WIN32SPL.FD ','SHELL32.FD  ',
     2'NETAPI32.FD ','OLECLI32.FD ','OLESVR32.FD ','RASAPI32.FD ',
     3'LZ32.FD     ','ADVAPI32.FD ',7*'            '/
      data filefi/'USER32.FI   ','GDI32.FI    ','KERNEL32.FI ',
     1'COMDLG32.FI ','COMCTL32.FI ','WIN32SPL.FI ','SHELL32.FI  ',
     2'NETAPI32.FI ','OLECLI32.FI ','OLESVR32.FI ','RASAPI32.FI ',
     3'LZ32.FI     ','ADVAPI32.FI ',7*'            '/            
      data number_include_files/13/
      data copying,found/2*.FALSE./
      data pound_define/'#DEFINE'/
c     return TRUE unless unless handles by DefWindowProc
      mainwindowproc = true
      select case (wMsgID)
         case (WM_CREATE)
           hdc=GetDC(hWnd)
           ierr=SelectObject(hdc,GetStockObject(SYSTEM_FIXED_FONT))
           ierr=GetTextMetrics(hdc,tm)
           cxChar=tm.tmAveCharWidth
           cyChar=tm.tmHeight+tm.tmExternalLeading
           ierr=ReleaseDC(hwnd,hdc)
           pen.color=yellow
           hpenyellow=CreatePenIndirect(pen)
           pen.color=red
           hpenred=CreatePenIndirect(pen)
           pen.color=green
           hpengreen=CreatePenIndirect(pen)
           pen.color=white
           hpenwhite=CreatePenIndirect(pen)
           pen.color=black
           hpenblack=CreatePenIndirect(pen)
           pen.color=blue
           hpenblue=CreatePenIndirect(pen)
           hpenbackground=hpenblue
           pen.color=lightblue
           hpenlightblue=CreatePenIndirect(pen)
           pen.color=purple
           hpenpurple=CreatePenIndirect(pen)
           color(1)=hpenblue
           color(2)=hpenyellow
           color(3)=hpengreen
           color(4)=hpenwhite
           color(5)=hpenblack
           color(6)=hpenred
           color(7)=hpenpurple
           color(8)=hpenlightblue
           IPIXX=640
           IPIXY=480
           IPIXLET=10     
           IPIXY1=IPIXY-1
           PIXY=IPIXY
           PIXY1=IPIXY1
           IPIXX1=IPIXX-1
           PIXX1=IPIXX1
           PIXX=IPIXX
               OPEN(7,FILE='corps.bmp',FORM='BINARY',STATUS='OLD',ERR=9)
               read(7,err=8,end=8) bitmapfileheader.bftype,
     1          bitmapfileheader.bfSize,bitmapfileheader.bfReserved1,
     2          bitmapfileheader.bfReserved2,bitmapfileheader.bfOffbits
               read(7,err=8,end=8) bitmapinfo.bisize,
     1          bitmapinfo.biWidth,bitmapinfo.biHeight,
     2          bitmapinfo.biPlanes,bitmapinfo.biBitCount,
     3          bitmapinfo.biCompression,bitmapinfo.biSizeImage,
     4          bitmapinfo.biXPelsPerMeter,bitmapinfo.biYPelsPerMeter,
     5          bitmapinfo.biClrUsed,bitmapinfo.biClrImportant
c    40 and 14 are the sizes of the 2 header blocks; pal is Integer*4 array
               iskip=(bitmapfileheader.bfOffbits-40-14)/4
               if(iskip.ge.1) then
                  do j=1,iskip
                     read(7,err=8134,end=8134) pal(j)
                  enddo
               endif
8134              if(bitmapinfo.biBitCount.eq.1) 
     1             linewidthbytes=(bitmapinfo.biWidth+7)/8
                  if(bitmapinfo.biBitCount.eq.4) 
     1             linewidthbytes=(bitmapinfo.biWidth+1)/2
                  if(bitmapinfo.biBitCount.eq.8) 
     1             linewidthbytes=bitmapinfo.biWidth
                  if(bitmapinfo.biBitCount.eq.24) 
     1             linewidthbytes=bitmapinfo.biWidth*3
               ibase=0
               do j=bitmapinfo.biheight,1,-1
                  read(7,err=8,end=8) (image(jj+ibase),
     1             jj=1,linewidthbytes)
                  ibase=ibase+linewidthbytes
               
               enddo
8              close(7)
9              continue
               ifirsttime=0
               call InvalidateRect(hWnd,Null,True)
         case (WM_COMMAND)
           select case (wParam)
             case (IDM_NEXT)
               INFILEPTR=LOCFAR(FILEN)
               IF(FORM(hinst,hWnd,fileform,itemchfile,infrows)) THEN
                  IF(Itemchfile(1).EQ.1) GO TO 7777
                  CALL GET_NAME_OF_FILE(FILEN,FILE_IN_H,NUMCHAR)
                  file_in_h(numchar+1:numchar+3)='H  '
                  file_out_def=file_in_h
                  file_out_def(numchar+1:numchar+3)='DEF'
                  file_out_fd=file_in_h
                  file_out_fd(numchar+1:numchar+3)='FD '
               else
                 nerr=destroywindow(hwnd)
                 return
               ENDIF
               open(3,file=file_in_h,status='OLD',err=13)
               open(4,file=file_out_def,status='UNKNOWN',err=13)
               open(5,file=file_out_fd,status='UNKNOWN',err=13)
628            read(3,10,end=629,err=629) a
10             format(a80)
                   do icount=1,80
                     if(a1(icount).gt.base_small_letters) 
     1                a1(icount)=a1(icount)-32
                   enddo
                   if(pound_define.eq.a(1:7)) then
                      istart=8
                      do while(a1(istart).eq.' '.and.istart.le.80)
                         istart=istart+1
                      enddo
                      iend=istart+1
                      do while((a1(iend).ge.'A'.and.a1(iend).le.'Z')
     1                 .or.(a1(iend).ge.'0'.and.a1(iend).le.'9')
     2                 .or.a1(iend).eq.'_')
                         iend=iend+1
                      enddo
                      If(a1(iend).eq.' ') then
                         istart2=iend
                         iend=iend-1
                         do while(a1(istart2).eq.' '.and.
     1                    istart2.le.80)
                            istart2=istart2+1
                         enddo
                         if(a1(istart2).eq.'(') istart2=istart2+1
                         iend2=istart2+1
                         hex=.false.
                         do while((a1(iend2).ge.'A'.and.a1(iend2).le.
     1                    'Z').or.a1(iend2).eq.'X'.or.a1(iend2).eq.'-'
     2                    .or.(a1(iend2).ge.'0'.and.a1(iend2).le.'9'))
                          if(a1(iend2).eq.'X') hex=.true.
                            iend2=iend2+1
                         enddo
                         iend2=iend2-1
                         found=.true.
                         do jj=istart2,iend2
                            if(a1(jj).lt.'0'.or.a1(jj).gt.'9') 
     1                       found=.false.
                         enddo
                         if(found.or.hex) then
                          if(hex) then
                             a1(istart2)='#'
                             ii=istart2+1
                             a1(ii)='0'
                             if(a1(iend2).eq.'L') iend2=iend2-1
                          endif
                          found=.true.
                          do jj=istart2,iend2
                             if(a1(jj).gt.'F') found=.false.
                          enddo
                          if(found) then
                          write(4,11,err=629) (a1(jj),jj=istart,iend)
                          write(5,112,err=629) (a1(jj),jj=istart,iend)
                          write(5,113,err=629) (a1(jj),jj=istart,iend)
                          write(5,114,err=629) (a1(jj),jj=istart,iend),
     1                     '=',(a1(jjj),jjj=istart2,iend2),')'
                          endif
                         endif
                      endif
11                    format(80a1)
112                   format('C*',80a1)
113                   format('       INTEGER*4 ',80a1)
114                   format('       PARAMETER (',80a1)
                   endif
               go to 628
629            close(4)
               close(3)
               close(5)
 13            nerr=destroywindow(hwnd)
           end select
         case (WM_PAINT)
            hDC=BeginPaint(hWnd,ps)
            ierr=SetBkMode(hDC,OPAQUE)
            ipreviouscolor=SetTextColor(hdc,yellow)
            ipreviouscolor=SetBkColor(hdc,blue)
            ierr=SelectObject(hDC,GetStockObject(SYSTEM_FIXED_FONT))
            ierr=GetTextMetrics(hDC,tm)
            cxChar=tm.tmAveCharWidth
            cyChar=tm.tmHeight+tm.tmExternalLeading
            Wintitle=filepre
            wintitle(numchar+4:numchar+4)='\0'c
            call SetWindowText(hWnd,WinTitle)
               hmemorydc=createcompatibledc(hdc)
               hbitmap=createdibitmap(hdc,locfar(bitmapinfo),
     1          CBM_INIT,locfar(image),locfar(bitmapinfo),
     2          DIB_RGB_COLORS)
               holdbitmap=selectobject(hmemorydc,hbitmap)
C   extent_x&y set by wm_size message handler and are correct               
               ierr=bitblt(hdc,0,0,extent_x,extent_y,
     1          hmemorydc,0,0,SRCCOPY)
               ierr=deletedc(hmemorydc)
               call deleteobject(hbitmap)
            if(ifirsttime.eq.0) then
               ifirsttime=1
               iberr=SendMessage(hwnd,WM_COMMAND,IDM_NEXT,1)
            endif
            Call EndPaint(hwnd,ps)
         case (WM_SIZE)
            IPIXX=LOWORD(lParam)
            IPIXY=HIWORD(lParam)
            IPIXX1=IPIXX-1
            IPIXY1=IPIXY-1
            pixx1=ipixx1
            pixy1=ipixy1
            pixx=ipixx
            pixy=ipixy
            extent_x=IPIXX
            extent_y=IPIXY
            ifirstpass=0
            call InvalidateRect(hWnd,Null,True)
         case (WM_CHAR)
           select case (wParam)
            case(escape)
               nerr=destroywindow(hwnd)
               return
            case DEFAULT
              mainwindowproc = DefWindowProc (hWnd, 
     1         wMsgID, wParam, lParam)
         END SELECT
      case (WM_CLOSE)
         nerr=destroywindow(hwnd)
      case (WM_DESTROY)
         Call DeleteObject(hbgbrush)
         Call DeleteObject(hpenblue)
         Call DeleteObject(hpenred)
         Call DeleteObject(hpenblack)
         Call DeleteObject(hpenwhite)
         Call DeleteObject(hpengreen)
         Call DeleteObject(hpenyellow)
         Call DeleteObject(hpenlightblue)
         Call DeleteObject(hpenpurple)
         Call PostQuitMessage(0)
      case DEFAULT
         mainwindowproc = DefWindowProc (hWnd, 
     1    wMsgID, wParam, lParam)
      END SELECT
      return
7777  nerr=destroywindow(hwnd)
      return
9940  NUMERRS=NUMERRS+1
      IF(NUMERRS.GT.20) nerr=destroywindow(hwnd)
      return
      end

      SUBROUTINE GET_NAME_OF_FILE(BUF,FILEEQUIPMENT,NUMCHAR)
      CHARACTER*30 FILEEQUIPMENT,BUF
      character*1 term
      PARAMETER (term=0)
      NUMCHAR=1
      DO WHILE (NUMCHAR.le.30.and.BUF(NUMCHAR:NUMCHAR).ne.term)
            NUMCHAR=NUMCHAR+1
      END DO
      DO J=1,30
         IF (J.LE.Numchar-1) THEN
            FILEEQUIPMENT(J:J)=BUF(J:J)
         ELSE
            IF (J.EQ.Numchar) THEN
               FILEEQUIPMENT(J:J)='.'
            ELSE IF (J.EQ.Numchar+1) THEN
               FILEEQUIPMENT(J:J)='E'
            ELSE IF (J.EQ.Numchar+2) THEN
               
               FILEEQUIPMENT(J:J)='Q'
            ELSE IF (J.EQ.Numchar+3) THEN
               FILEEQUIPMENT(J:J)='U'
            ELSE
               FILEEQUIPMENT(J:J)=' '
            ENDIF
         ENDIF
      END DO
      RETURN
      END
      Subroutine Put_Buffer(name1,name2,value1,value2,ipointer,length)
      Real name1(1),name2(1)
      ipointer=ipointer+1
      if(ipointer.gt.length) ipointer=1
      name1(ipointer)=value1
      name2(ipointer)=value2
      Return
      End
      Subroutine Get_Buffer(name1,value1,ipointer,length,index)
      Real name1(1)
      iipointer=ipointer+index
      if(iipointer.gt.length) iipointer=iipointer-length
      if(iipointer.lt.1) iipointer=length+iipointer
      value1=name1(iipointer)
      Return
      End

