rem Sharpen ... Rev 4.0
      rem Assembly Language version
      
      rem=======================================================
      rem This program sharpens the image in a .bmp or .jpg file
      rem=======================================================
      
      himem=lomem + 100000000
      *FLOAT 64
      
      rem Setup
      proc_setup
      
      rem Select the picture for smoothing
      proc_pichoose
      
      rem Display the picture initially
      proc_gendisp(1,fil$,0,0,xscreen%,yscreen%)
      
      rem 2nd setup
      proc_setup2
      
      rem Select Smoothing System
      proc_select
      
      rem Switch to Full Screen
      proc_fullscreen
      
      colour 132,0,0,50:colour 4,0,0,50 : colour 132 : cls
      colour 3:print tab(15,15);"PLEASE WAIT for a few seconds."
      
      Cnt&=1 : colour 3
      repeat
        rem Sharpen the Picture
        call sharp%
        
        rem Display Picture
        proc_mdisp : print tab(1,1);Cnt& : Cnt&+=1
        
        rem Copy pfmir to pf
        call recopy%,pfmir%,pf%,!lgth%
        
        b&=0 : proc_mclick(b&)
        if b&=4 then print tab(5,1);"Please wait..."
      until b&=1
      
      rem Save pictures to disc, at path destination same as source picture
      proc_picsave
      
      a$=inkey$(100)
      quit
      end
      rem End of Program +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Setup
      def proc_setup
      mode 22 : colour 3 : colour 132,0,0,50 : colour 4,0,0,50 : colour 132 : cls : off
      
      sys "GetSystemMetrics", 0 to xscreen%
      sys "GetSystemMetrics", 1 to yscreen%
      
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem 2nd setup
      def proc_setup2
      local a,b,m&,q$
      
      colour 3:print tab(5,5);".bmp loaded. Press any key or left-click to continue."
      
      m&=0 : q$=""
      repeat
        mouse a,b,m&
        q$=inkey$(1)
      until (m&<>0 or q$<>"")
      cls
      
      rem Various Variables
      dim x% 3, s% 0, pr% 3
      dim j% 3, k% 3, r% 0, w% 3, recopy% 200
      dim exab% 9, v% 0, jr% 3, d% 0, df% 3, rf% 3
      dim sharp% 2000, itmp% 3, ftmp% 7
      dim bsave% 500, g% 0, w% 0, f4% 7
      
      |f4%=4.0
      
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_sharp(pass&)
        proc_bsave(pass&)
        proc_recopy(pass&)
      next pass&
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Choose a picture
      def proc_pichoose
      local g%,rn%,n$,Flg&,fullname$,command$,m&,a,b
      
      dim pq% 75, ff% 18, fm% 255
      !pq%=76
      pq%!4=@hwnd%
      pq%!12=ff%
      pq%!28=fm%
      pq%!32=256
      pq%!52=6
      
      colour 3:print tab(5,5);"Press -j- or left-click for a jpg, -b- or right-click for a bmp original image."
      
      repeat
        mouse a,b,m&
        q$=inkey$(1)
        if m&=4 then q$="j"
        if m&=1 then q$="b"
      until (q$="j" or q$="b")
      
      case q$ of
        when "b":
          $ff% ="BMP files"+chr$0+"*.bmp"+chr$0+chr$0
        when "j":
          $ff% ="JPG files"+chr$0+"*.jpg"+chr$0+chr$0
      endcase
      
      sys "GetOpenFileName", pq% to result%
      
      if result%<>0 then fullname$ = fn_nulterm$(fm%)
      
      rn%=len(fullname$)
      g%=0 : pic$=""
      repeat
        n$=mid$(fullname$,rn%-g%,1)
        if n$<>"\" then pic$=n$+pic$ : g%+=1
      until n$="\"
      
      pre$=left$(fullname$,rn%-g%)
      rem Change the current Directory
      command$="CD "+chr$(34)+pre$+chr$(34)
      oscli command$
      fil$=pre$+pic$
      endproc
      rem---------------------------------------------------------------------
      
      rem Convert null-terminated string to BASIC format
      def fn_nulterm$(Z%)
      local A$
      while ?Z%<>0
        A$+=chr$(?Z%)
        Z%+=1
      endwhile
      =A$
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Set up use of Full Screen
      def proc_fullscreen
      
      sys "GetSystemMetrics", 0 to xscreen%
      sys "GetSystemMetrics", 1 to yscreen%
      sys "SetWindowLong",@hwnd%,-16,&16000000
      sys "SetWindowPos",@hwnd%,-1,0,0,xscreen%,yscreen%,0
      vdu 23,22,xscreen%;yscreen%;8,16,16,1 : rem Set fullscreen mode
      mouse off : off : rem Turns off the Mouse Pointer and the Cursor
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Choose Sharpening Factor
      def proc_select
      
      print tab(5,10);"Choose the relative weights of the surrounding pixels."
      print tab(5,12);"The surrounding pixels can have a weight between 0 and 1."
      
      colour 2: print tab(5,16);"Left-click to repeat SHARPEN, right-click to EXIT."
      
      colour 3
      repeat
        input tab(10,14);"Enter the weight for the Surrounding Pixels (0.2)",lam
        lam*=1.0
        if lam=0.0 then lam=0.2
      until (lam>0.0 and lam<1.0)
      
      a$=inkey$(50) : cls
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Display Bitmap from memory
      def proc_mdisp
      sys "SetStretchBltMode", @memhdc%, 3
      command$="MDISPLAY "+str$~pfmir%+" 0,0,"+str$(2*xscreen%)+","+str$(2*yscreen%)
      oscli command$
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Sharpen Utility - Assembly Routine
      def proc_sharp(opt&)
      P%=sharp%
      [opt opt&
      
      mov edx,0
      mov [j%],edx
      
      .ocirc
      inc dword [j%]
      mov eax,0
      mov [k%],eax             ;Initialise loop control
      .circ
      inc dword [k%]
      
      mov eax,[wlim%]       ;Calc pr%
      mov ebx,[j%]
      dec ebx
      imul eax,ebx
      mov ebx,[k%]
      dec ebx
      add eax,ebx
      add eax,ebx
      add eax,ebx
      add eax,54
      mov [pr%],eax         ;Calc pr%
      
      mov al,0
      mov [d%],al
      
      .rep
      mov eax,[pr%]           ;Calculate dfault reference, df%
      mov bl,[d%]
      cmp bl,2
      jl ninc2
      inc eax
      .ninc2
      cmp bl,1
      jl ninc1
      inc eax
      .ninc1
      mov [df%],eax           ;df%=pr%+d%
      mov [rf%],eax           ;Dfault vlue 0f rf% also pr%+d%
      
      mov cl,pf%[eax]         ;eax=rf% at this point
      mov edx,0
      .again
      mov exab%[edx],cl       ;Load up exab%n, (n=0 t0 8) with vlue 0f current pixel
      inc edx
      cmp edx,8
      jle again
      
      mov eax,[k%]            ;If k%<wid% do flwng
      cmp eax,[wid%]
      jnl tbigk
      mov ebx,[rf%]
      add ebx,3
      mov cl,pf%[ebx]
      mov edx,5
      mov exab%[edx],cl       ;Update exab%5
      .tbigk mov eax,[k%]     ;If k%>1 do flwng
      cmp eax,1
      jng nowj
      mov ebx,[rf%]
      sub ebx,3
      mov cl,pf%[ebx]
      mov edx,3
      mov exab%[edx],cl       ;Update exab%3
      
      .nowj
      mov eax,[j%]            ;If j%>1, do following
      cmp eax,1
      jng conta
      mov ebx,[df%]
      sub ebx,[jr%]
      mov [rf%],ebx
      mov cl,pf%[ebx]
      mov edx,1
      mov exab%[edx],cl       ;Update exab%1
      mov eax,[k%]            ;If also k%<wid% do flwng
      cmp eax,[wid%]
      jnl tbig0
      mov ebx,[rf%]
      add ebx,3
      mov cl,pf%[ebx]
      mov edx,2
      mov exab%[edx],cl       ;Update exab%2
      .tbig0 mov eax,[k%]     ;If also k%>1 do flwng
      cmp eax,1
      jng conta
      mov ebx,[rf%]
      sub ebx,3
      mov cl,pf%[ebx]
      mov edx,0
      mov exab%[edx],cl       ;Update exab%0
      
      .conta
      mov eax,[j%]            ;If j%<hei%, do following
      cmp eax,[hei%]
      jnl contb
      mov ebx,[df%]
      add ebx,[jr%]
      mov [rf%],ebx
      mov cl,pf%[ebx]
      mov edx,7
      mov exab%[edx],cl       ;Update exab%7
      mov eax,[k%]            ;If also k%<wid% do flwng
      cmp eax,[wid%]
      jnl tbig1
      mov ebx,[rf%]
      add ebx,3
      mov cl,pf%[ebx]
      mov edx,8
      mov exab%[edx],cl       ;Update exab%8
      .tbig1 mov eax,[k%]     ;If also k%>1 do flwng
      cmp eax,1
      jng contb
      mov ebx,[rf%]
      sub ebx,3
      mov cl,pf%[ebx]
      mov edx,6
      mov exab%[edx],cl       ;Update exab%6
      
      .contb
      mov eax,0               ;Adds surrounding 4 pixels
      mov ecx,0
      mov ebx,1
      .bgain
      mov cl,exab%[ebx]
      add eax,ecx
      inc ebx
      inc ebx
      cmp ebx,7
      jbe bgain
      mov [itmp%],eax
      
      finit                         ;Sharpen
      fld qword [^lam]
      fild dword [itmp%]
      fmulp st1,st0
      fld qword [f4%]
      fdivp st1,st0
      
      mov eax,0
      mov edx,4
      mov al,exab%[edx]
      mov [itmp%],eax
      fild dword [itmp%]
      fsubrp st1,st0
      fld1
      fld qword [^lam]
      fsubp st1,st0
      fdivp st1,st0
      fistp dword [itmp%]
      mov ecx,[itmp%]
      
      cmp ecx,0
      jge aok
      mov ecx,0
      .aok
      cmp ecx,255
      jle bok
      mov ecx,255                 ;Sharpen
      
      .bok
      mov eax,4                   ;Adjust Colour accordingly
      mov exab%[eax],cl
      mov ebx,[pr%]
      mov ecx,0
      mov cl,[d%]
      add ebx,ecx
      mov cl,exab%[eax]
      mov pfmir%[ebx],cl          ;Adjust Colours accordingly
      
      inc byte [d%]
      mov al,[d%]
      cmp al,3
      jb near rep
      
      mov eax,[k%]
      cmp eax,[wid%]
      jl near circ
      
      mov edx,[j%]
      cmp edx,[hei%]
      jl near ocirc
      
      ret
      ]
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Save pictures to disc, at path destination same as source picture
      def proc_picsave
      
      colour 132:colour 3:print tab(0,0);"Saving Picture"
      Adn$="H.bmp"
      ps%=instr(pic$,".")
      newpic$=left$(pic$,(ps%-1))+Adn$
      Dpath$=pre$+newpic$
      print tab(0,1);"File located at: ";Dpath$
      
      ?g%=openout Dpath$
      call bsave% : rem Byte Save Routine
      close#?g%
      
      colour 132:colour 3:print tab(0,3);"DONE"
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Byte Save - Assembly Routine
      def proc_bsave(opt&)
      P%=bsave%
      [opt opt&
      
      mov ebx,0
      mov bl,[g%]           ;Puts channel ref t0 ebx
      mov edx,0
      mov [w%],edx          ;Initialise loop counter
      
      .loop
      mov al,pfmir%[edx]
      call "osbput"         ;Puts al t0 channel ebx
      inc dword [w%]
      mov edx,[w%]
      cmp edx,[lgth%]
      jle loop
      ret
      ]
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Display a Picture
      def proc_gendisp(Ctr&,picture$,xpos%,ypos%,xsize%,ysize%)
      
      sys "LoadLibrary", "OLEAUT32.DLL"
      sys "GetModuleHandle", "OLEAUT32.DLL" to oleaut32%
      sys "GetProcAddress", oleaut32%, "OleLoadPicturePath" to olpp%
      if olpp%=0 error 0, "Could not get address of OleLoadPicturePath"
      
      dim iid% 15, gpp% 3, hmw% 3, hmh% 3, picture% 513
      sys "MultiByteToWideChar", 0, 0, picture$, len(picture$), picture%, 256 to lon%
      picture%!(2*lon%) = 0
      
      iid%!0  = &7BF80980
      iid%!4  = &101ABF32
      iid%!8  = &AA00BB8B
      iid%!12 = &AB0C3000
      
      sys olpp%, picture%, 0, 0, 0, iid%, gpp%
      if !gpp% = 0 error 0, "OleLoadPicturePath failed"
      
      sys !(!!gpp%+24), !gpp%, hmw% : rem. IPicture::get_Width
      sys !(!!gpp%+28), !gpp%, hmh% : rem. IPicture::get_Height
      sys !(!!gpp%+32), !gpp%, @memhdc%, xpos%, ypos%, xsize%, ysize%, 0, !hmh%, !hmw%, -!hmh%, 0 to res%
      if res% error 0, "IPicture::Render failed"
      
      sys !(!!gpp%+8), !gpp% : rem. IPicture::Release
      sys "InvalidateRect", @hwnd%, 0, 0
      sys "UpdateWindow", @hwnd%
      
      if Ctr&=1 then
        rem Reads a picture as a BMP
        proc_read_as_bmp(picture$)
      endif
      
      endproc
      rem ====================================================================
      
      rem Reads a picture as a BMP
      def proc_read_as_bmp(fil$)
      
      dim temp% 255, bm% 86
      bm% = (bm% + 3) and -4  : rem Ensures bm% is a multiple of FOUR
      
      sys "MultiByteToWideChar", 0, 0, fil$, len(fil$), temp%, 256
      
      sys "LoadLibrary", "OLEAUT32.DLL" to oleaut32%
      sys "GetProcAddress", oleaut32%, "OleLoadPicturePath" to olpp%
      
      I% = &7BF80980 : rem. 128-bit iid
      J% = &101ABF32
      K% = &AA00BB8B
      L% = &AB0C3000
      
      sys olpp%, temp%, 0, 0, 0, ^I%, ^G% : rem. OleLoadPicturePath
      if G% = 0 error 0, "Cannot load file """+fil$+""""
      
      sys !(!G%+12), G%, ^hbm% : rem. IPicture::get_Handle
      
      sys "GetObject", hbm%, 84, bm%
      W% = bm%!4
      H% = bm%!8
      
      dim lgth% 3
      
      !lgth% = 54+H%*((W%*3+3)and-4)
      dim pf% !lgth%, pfmir% !lgth%
      
      dim wlim% 3, wid% 3, hei% 3, siz% 3
      
      !wlim%=((W%*3+3)and-4)
      
      rem BMP header for pfmir% array
      proc_bmpheader(W%,H%)
      
      $pf% = "BM"
      pf%!2 = lgth%
      pf%!10 = 54
      pf%!14 = 40
      pf%!18 = W%
      pf%!22 = H%
      pf%!26 = &180001
      
      sys "GetDIBits", @memhdc%, hbm%, 0, H%, pf%+54, pf%+14, 0
      
      sys !(!G%+8), G% : rem. IPicture::Release
      
      !wid%=pf%!(18)
      !hei%=pf%!(22)
      !siz%=pf%!(2)
      endproc
      rem ===============================================================
      
      rem Standard Header setup
      def proc_bmpheader(wdth%,hght%)
      
      P%=pfmir%
      [OPT 0
      DB "BM"          ; Signature
      DD !lgth%        ; Total file bytes
      DD 0             ; Set t0 zero
      DD 54            ; Header bytes
      DD 40            ; Offset t0 Data
      DD wdth%         ; Image Width
      DD hght%         ; Image Height
      DW 1             ; Bit planes
      DW 24            ; Colour depth in bits
      DD 0             ; Compression type=0=none
      DD !lgth%-54     ; Image size net 0f header
      DD 0             ; Set t0 zero
      DD 0             ; Set t0 zero
      DD 0             ; Set t0 zero
      DD 0             ; Set t0 zero
      ]
      endproc
      rem =======================================================================
      
      rem Assembly Routine for Recopy
      def proc_recopy(opt&)
      P%=recopy%
      [opt opt&
      
      mov esi,[ebp+2]
      mov edi,[ebp+7]
      mov eax,[ebp+12]
      mov ecx,[eax]
      cld
      rep movsb
      
      ret
      ]
      endproc
      rem ======================================================================
      
      rem Check for a mouse click
      def proc_mclick(return b&) : local x,y
      
      rem Mouse debounce
      repeat
        mouse x,y,b&
      until b&=0
      
      repeat
        mouse x,y,b&
        sys "Sleep", 10
      until (b&=1 or b&=4)
      endproc
      rem ===============================================================