rem Solariser (Assembly Version) ... Rev 4.1
      rem A J Tooth // October 2005
      on error if (err=17) then quit
      
      rem Updated January 2006 to handle both jpg and bmp
      rem and fully variable solarisation threshold.
      
      rem ==================================
      rem Only accepts 24-bit colour format
      rem ==================================
      
      himem=lomem + 100000000
      *FLOAT 64
      
      rem Setup
      proc_setup
      
      rem First choose a picture from a list
      proc_pichoose
      
      rem Go to fullscreen
      proc_fullscreen
      colour 3
      
      rem Display the picture initially
      proc_gendisp(1,fil$,0,0,xscreen%,yscreen%)
      
      rem ASM compilation
      proc_setup2
      
      rem Analyse the .bmp at byte level, including header data.
      proc_look
      
      rem Choose solarising level
      ms&=0 : proc_choice(1,ms&)
      *REFRESH OFF
      repeat
        rem Solarised version.
        proc_Solar
        print tab(1,1);?sof%;"  ";
        *REFRESH
        rem Choose solarising level
        ms&=0 : proc_choice(0,ms&)
        
      until ms&<>0
      
      rem Save the picture
      proc_picsave
      
      proc_mclick(b&)
      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 : off : cls
      
      dim x% 3, q% 3, s% 0, pr% 3, bl% 0, gr% 0, re% 0, h% 0, rs% 0, t% 0
      dim wid% 3, hei% 3, fset% 3, siz% 3, j% 3, k% 3, w% 3, cc% 0, sof% 0
      
      rem Default solarisation threshold
      ?sof%=200
      endproc
      rem ==================================================================
      
      rem Select .bmp file
      def proc_pichoose
      local g%,rn%,n$
      
      dim pf% 75, ff% 30, fm% 255
      !pf% = 76
      pf%!4 = @hwnd%
      pf%!12 = ff%
      pf%!28 = fm%
      pf%!32 = 256
      pf%!52 = 6
      $ff% ="Images"+chr$0+"*.bmp;*.gif;*.jpg"+chr$0+chr$0
      
      sys "GetOpenFileName", pf% 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 Display bitmap
      def proc_disp
      
      sys "SetStretchBltMode", @memhdc%, 3
      command$="MDISPLAY "+str$~pfmir%+" 0,0,"+str$(2*xscreen%)+","+str$(2*yscreen%)
      oscli command$
      endproc
      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 Read in the .bmp to a file in memory
      def proc_setup2
      
      dim bsave% 100, g% 0
      rem Dual-pass assembly, in case of labels
      for pass%=0 to 2 step 2
        proc_bsave(pass%)
      next pass%
      
      dim swop% 1000
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_swop(pass&)
      next pass&
      
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Choose solarising level
      def proc_choice(Ctr&,return b&)
      local x,y,in&,n&
      
      if Ctr&=1 then
        colour 3:print tab(5,5);"Rotate the mouse-wheel or press the up or down arrow key to set the solarisation threshold."
        print tab(5,7);"Click either mouse button to exit and save."
        *REFRESH
      endif
      
      rem Mouse debounce
      repeat
        mouse x,y,b&
      until b&=0
      
      in&=0 : n&=0
      
      repeat
        mouse x,y,b&
        in&=inkey(1)
        n&=-1*inkey(-58)-2*inkey(-42)
        if in&=141 then n&=1
        if in&=140 then n&=2
      until (n&<>0 or b&<>0)
      
      if n&=1 then if ?sof%<255 then ?sof%+=1
      if n&=2 then if ?sof%>0 then ?sof%-=1
      
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Analyse the .bmp at byte level, including header data.
      def proc_look
      
      rem Collect size data from the Header
      !wid%=pf%!(18)
      !hei%=pf%!(22)
      !fset%=pf%!(10)
      !siz%=pf%!(2)
      
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Solarised version.
      def proc_Solar
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &100
      
      call swop%
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &20
      
      rem Display Picture
      proc_disp
      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 ===============================================================
      
      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 Base Colour Conversion - Assembly Routine
      def proc_swop(opt&)
      
      P%=swop%
      [opt opt&
      
      mov edx,0
      mov [j%],edx
      
      .jloop
      mov edx,0
      mov [k%],edx
      
      .kloop
      mov eax,[Wlim%]
      imul eax,[j%]           ;picture ref
      add eax,[k%]
      add eax,[k%]
      add eax,[k%]
      add eax,54
      
      mov dl,0
      mov [cc%],dl
      
      .lloop
      mov dl,[cc%]
      cmp dl,0
      ja ntb1
      mov cl,pf%[eax]
      jmp rnd1
      
      .ntb1
      cmp dl,1
      ja ntg1
      mov cl,pf%[eax+1]
      jmp rnd1
      
      .ntg1
      mov cl,pf%[eax+2]
      
      .rnd1
      cmp cl,[sof%]
      jbe nch
      mov bl,cl
      sub bl,[sof%]
      shl bl,1
      sub cl,bl
      
      .nch
      mov dl,[cc%]
      cmp dl,0
      ja ntb2
      mov pfmir%[eax],cl
      jmp rnd2
      
      .ntb2
      cmp dl,1
      ja ntg2
      mov pfmir%[eax+1],cl
      jmp rnd2
      
      .ntg2
      mov pfmir%[eax+2],cl
      
      .rnd2
      inc byte [cc%]
      mov dl,[cc%]
      cmp dl,3
      jl near lloop
      
      inc dword [k%]
      mov edx,[k%]
      cmp edx,[wid%]
      jl near kloop
      
      inc dword [j%]
      mov edx,[j%]
      cmp edx,[hei%]
      jl near jloop
      
      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 Xlim% 3, Ylim% 3, Wlim% 3
      
      !Xlim%=W%-1 : !Ylim%=H%-1 : !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
      endproc
      rem ===============================================================
      
      rem Prints the backdrop for the screen message
      def proc_back(Xs%,Ys%,Ws%,Hs%,Rr&,Gg&,Bb&)
      local h&,Rf&,Gf&,Bf&
      
      for h&=0 to 30
        Rf&=Rr&*h&/30 : Gf&=Gg&*h&/30 : Bf&=Bb&*h&/30
        colour 9,Rf&,Rf&,Rf& : gcol 9
        rectangle fill Xs%+h&,Ys%+h&,Ws%-2*h&,Hs%-2*h&
      next h&
      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 Save the picture
      def proc_picsave
      *REFRESH ON
      rem Save picture to disc
      ps%=instr(pic$,".")
      newpic$=left$(pic$,(ps%-1))+"SS.bmp"
      
      Dpath$=pre$+newpic$
      ?g%=openout Dpath$
      call bsave% : rem Byte Save Routine
      close#(?g%)
      
      print tab(0,1);"DONE"
      print tab(0,3);"Picture is saved as: ";newpic$
      print tab(0,4);"in the same directory as the original."
      print tab(0,6);"Left-click to finish."
      endproc
      rem =======================================================================