rem Solariser (Assembly Version) ... Rev 2.2
      rem A J Tooth // October 2005
      rem Modified to read BMP,JPG,GIF,EMF,WMF,ICO by R T Russell // October 2005
      
      himem=lomem + 30000000
      *FLOAT 64
      
      rem Setup
      proc_setup
      
      rem First choose a picture from a list
      proc_pichoose
      fil$=pre$+pic$
      
      rem Display the .bmp as is
      cls : clg : off
      proc_disp(fil$)
      
      print tab(5,5);".bmp loaded. Press any key to continue."
      a$=get$
      cls
      
      rem read in the .bmp to a file in memory
      proc_read
      
      rem Analyse the .bmp at byte level, including header data.
      proc_look
      
      proc_fullscreen
      colour 3 : colour 132,0,0,50 : colour 4,0,0,50 : colour 132 : cls
      
      rem Grey version.
      proc_Grey
      
      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."
      
      a$=get$
      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
      
      dim lgth% 3, 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
      
      endproc
      rem ==================================================================
      
      rem Select .bmp file
      def proc_pichoose
      local g%,rn%,n$
      
      dim pf% 75, fm% 255
      ff$ = "Image files"+chr$0+"*.BMP;*.JPG;*.JPEG;*.GIF;*.EMF;*.WMF;*.ICO"+chr$0+"All files"+chr$0+"*.*"+chr$0+chr$0
      !pf% = 76
      pf%!4 = @hwnd%
      pf%!12 = !^ff$
      pf%!28 = fm%
      pf%!32 = 256
      pf%!52 = 6
      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$
      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 ==================================================================
      
      def proc_disp(CurPic$)
      
      sys "SetStretchBltMode", @memhdc%, 3
      command$="DISPLAY"+chr$(34)+CurPic$+chr$(34)+" 0,0,2048,1536"
      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 etc. to a file in memory
      def proc_read
      
      dim temp% 255, bm% 86
      bm% = (bm% + 3) and -4
      
      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
      
      !lgth% = 54+H%*((W%*3+3)and-4)
      dim pf% !lgth%, pfmir% !lgth%
      
      $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
      
      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, jref% 3, kref% 3, addend% 100, ksum% 3, prx% 3, ader% 3
      rem Dual-pass assembly, in case of labels
      for pass%=0 to 2 step 2
        proc_swop(pass%)
        proc_addend(pass%)
      next pass%
      
      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)
      
      colour 3:print tab(5,5);"Press -h-,-m- or -l- for high, medium or low level solarisation effect. (h)"
      
      sol$=get$
      if (sol$<>"m" and sol$<>"l") then sol$="h"
      
      case sol$ of
        when "l": ?sof%=200
        when "m": ?sof%=160
        when "h": ?sof%=130
      endcase
      
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Grey version.
      def proc_Grey
      Bpath$=pre$
      cls
      print tab(15,15);"PLEASE WAIT A MOMENT."
      
      rem Prepare for adjusting the width to be a multiple of 4 (a .bmp format rule)
      ?rs%=4 - ((3*(!wid%)) mod 4) : if ?rs%=4 then ?rs%=0
      
      colour 130:colour 4
      rem Identical header section
      for ?s%=0 to 53
        pfmir%?(?s%)=pf%?(?s%)
      next
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &100
      
      call swop%
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &20
      rem dn%=int((!j%)/15) : print tab(5,40);string$(dn%,chr$(128))
      
      rem Save pictures to disc
      ps%=instr(pic$,".")
      newpic$=left$(pic$,(ps%-1))+"BC"+sol$+".bmp"
      
      Dpath$=Bpath$+newpic$
      ?g%=openout Dpath$
      call bsave% : rem Byte Save Routine
      close#(?g%)
      rem Display Picture
      proc_disp(newpic$)
      endproc
      rem ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      
      rem Addend - Assembly Routine
      def proc_addend(opt%)
      P%=addend%
      [opt opt%
      
      mov cl,0
      mov eax,[k%]
      mov bl,[rs%]
      cmp eax,[wid%]
      jne nt1
      inc cl
      .nt1 cmp bl,0
      je nt2
      inc cl
      .nt2 cmp cl,2
      jne noneed
      mov al,0               ;Executed 0nly If k%=wid% And rs%>0
      mov [h%],al
      mov ebx,[prx%]
      add ebx,3
      .more0
      mov byte pfmir%[ebx],0
      inc byte [h%]
      inc ebx
      mov al,[h%]
      cmp al,[rs%]
      jl more0
      
      .noneed ret
      ]
      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,1
      mov [j%],edx
      
      .jloop
      mov edx,1
      mov [k%],edx
      
      .kloop
      mov eax,[j%]
      cmp eax,1
      jne ntfrst1
      mov ebx,[fset%]       ;Initial Value 0f pr% is fset%
      mov [pr%],ebx
      
      mov ebx,[wid%]        ;ebx Loaded with Increment Value
      add ebx,[wid%]
      add ebx,[wid%]
      mov edx,0
      mov dl,[rs%]
      add ebx,edx           ;ebx Loaded with Increment Value
      mov [ader%],ebx       ;Save Increment Value
      
      .ntfrst1
      mov eax,[j%]
      cmp eax,1
      je ntfrst2
      mov eax,[k%]
      cmp eax,1
      jne ntfrst2
      mov ebx,[ader%]
      add [pr%],ebx         ;Increase pr% bi (3*wid%)+rs% When j%>1
      
      .ntfrst2
      mov eax,[k%]
      cmp eax,1
      jne none
      mov eax,0
      mov [ksum%],eax
      .none mov eax,[k%]
      cmp eax,1
      je noinc2
      inc dword [ksum%]
      inc dword [ksum%]
      inc dword [ksum%]
      
      .noinc2
      mov ebx,[pr%]
      add ebx,[ksum%]
      mov [prx%],ebx
      
      mov dl,0
      mov [cc%],dl
      
      .lloop
      mov dl,[cc%]
      cmp dl,0
      ja ntb1
      mov cl,pf%[ebx]
      jmp rnd1
      
      .ntb1
      cmp dl,1
      ja ntg1
      mov cl,pf%[ebx+1]
      jmp rnd1
      
      .ntg1
      mov cl,pf%[ebx+2]
      
      .rnd1
      cmp cl,[sof%]
      jbe nch
      mov al,cl
      sub al,[sof%]
      shl al,1
      sub cl,al
      
      .nch
      mov dl,[cc%]
      cmp dl,0
      ja ntb2
      mov pfmir%[ebx],cl
      jmp rnd2
      
      .ntb2
      cmp dl,1
      ja ntg2
      mov pfmir%[ebx+1],cl
      jmp rnd2
      
      .ntg2
      mov pfmir%[ebx+2],cl
      
      .rnd2
      inc byte [cc%]
      mov dl,[cc%]
      cmp dl,3
      jl near lloop
      
      call addend%
      
      inc dword [k%]
      mov edx,[k%]
      cmp edx,[wid%]
      jle near kloop
      
      inc dword [j%]
      mov edx,[j%]
      cmp edx,[hei%]
      jle near jloop
      
      ret
      ]
      endproc