Patch title: Release 96 bulk changes
Abstract:
File: /pliant/protocol/vnc/ui_client.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/convert.pli"
module "/pliant/graphic/filter/io.pli"
module "/pliant/graphic/ui/server/api.pli"
module "/pliant/graphic/ui/server/image.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/language/type/misc/blob.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/storage/database.pli"
module "ocr.pli"
module "/pliant/language/os.pli"

constant optimal true
constant use_hextile true
constant trace_encoding false
constant trace_compression true

if trace_compression
  module "/pliant/util/encoding/pack4.pli"
  gvar Int rcount := 0
  gvar Int hcount := 0
  gvar Int pcount := 0


function vncEncryptBytes bytes passwd
  arg Address bytes ; arg CStr passwd
  external "/pliant/pliant/protocol/vnc/vncchallenge.so" "vncEncryptBytes"


ui_type VncPixelFormat
  field uInt8 bits_per_pixel
  field uInt8 depth
  field uInt8 big_endian_flag
  field uInt8 true_color_flag
  field uInt16_hi red_max green_max blue_max
  field uInt8 red_shift green_shift blue_shift
  field Byte padding1 padding2 padding3


ui_type VncSession
  field Link:Stream stream
  field Link:ImagePixmap fb
  field Link:Bool osx
  field Sem vnc_sem
  field Int refresh_counter <- 0
  # scripting context
  field Link:UIServerContext ui
  field Int mouse_x mouse_y ; field Int mouse_buttons <- 0
  field List:Str images_path
  field Dictionary images_cache
  field (List Link:Font) ocr_fonts
  field Str ocr_options
  field CBool ocr_trace <- false
  # ui context
  field Str action
  field Link:Str image_filename
  field Int selected_x0 selected_y0
  field Int selected_x1 selected_y1

function build s
  arg_w VncSession s
  s stream :> new Stream
  s:stream open "null:" in+out+safe
  s fb :> new ImagePixmap
  s:fb setup (image_prototype 0 0 1 1 1 1 color_gamut:"rgb") ""
  s osx :> new Bool false
  s image_filename :> new Str
  var Link:Font f
  f :> font "Bitstream Vera Sans" ; s ocr_fonts += f
  f :> font "Bitstream Vera Sans Bold" ; s ocr_fonts += f
  if false
    if (exists font_database:data:fullname:"Free Sans")
      console "use Free Sans font" eol
      f :> font "Free Sans" ; s ocr_fonts += f
    if (exists font_database:data:fullname:"Free Sans Bold")
      f :> font "Free Sans Bold" ; s ocr_fonts += f


#--------------------------------------------------------------------------


method session send_refresh_request
  arg_rw VncSession session
  implicit session
    var uInt8 message := 3 ; stream raw_write addressof:message 1
    var uInt8 incremental := 1 ; stream raw_write addressof:incremental 1
    var uInt16_hi x_position := 0 ; stream raw_write addressof:x_position uInt16_hi:size
    var uInt16_hi y_position := 0 ; stream raw_write addressof:y_position uInt16_hi:size
    var uInt16_hi width := fb size_x ; stream raw_write addressof:width uInt16_hi:size
    var uInt16_hi height := fb size_y ; stream raw_write addressof:height uInt16_hi:size

method session send_key down k
  arg_rw VncSession session ; arg CBool down ; arg Int k
  implicit session
    var uInt8 message := 4 ; stream raw_write addressof:message 1
    var uInt8 down_flags := shunt down 1 0 ; stream raw_write addressof:down_flags 1
    for (var Int i) 1 2
      var uInt8 padding := 0 ; stream raw_write addressof:padding 1
    var uInt32_hi key32 := k ; stream raw_write addressof:key32 uInt32_hi:size


method session send_mouse x y buttons
  arg_rw VncSession session ; arg Int x y buttons
  implicit session
    var Int buttons8 := buttons ; stream raw_write addressof:buttons8 1
    var uInt16_hi mouse_x16 := x ; stream raw_write addressof:mouse_x16 uInt16_hi:size
    var uInt16_hi mouse_y16 := y ; stream raw_write addressof:mouse_y16 uInt16_hi:size


#--------------------------------------------------------------------------


method session timer_refresh
  arg_rw VncSession session
  implicit session
    while stream=success
      sleep 0.25
      vnc_sem request
      send_refresh_request
      stream flush anytime
      vnc_sem release
    

method session screen_update context
  arg_rw VncSession session ; arg_rw UIServerContext context
  implicit session
    var Pointer:Stream connection :> context connection
    while not stream:atend
      stream raw_read addressof:(var uInt8 message) 1
      if message=0
        stream raw_read addressof:(var uInt8 padding) 1
        stream raw_read addressof:(var uInt16_hi number_of_rectangles) uInt16_hi:size
        if optimal
          connection oraw open (cast "group" Ident) body
        for (var Int i) 0 number_of_rectangles-1
          stream raw_read addressof:(var uInt16_hi x_position) uInt16_hi:size
          stream raw_read addressof:(var uInt16_hi y_position) uInt16_hi:size
          stream raw_read addressof:(var uInt16_hi width) uInt16_hi:size
          stream raw_read addressof:(var uInt16_hi height) uInt16_hi:size
          stream raw_read addressof:(var uInt32_hi encoding) uInt32_hi:size
          if x_position+width>fb:size_x or y_position+height>fb:size_y
            console "corrupted VNC redraw stream (1)" eol
            stream configure "shutdown"
            return
          if encoding=0
            if trace_encoding
              console "raw" eol
            if optimal
              connection oraw open (cast "image_write_raw" Ident) "fb" (cast x_position Int) (cast y_position Int) (cast x_position+width Int) (cast y_position+height Int) body
            for (var Int y) y_position y_position+height-1
              var Address pixels := fb write_map x_position y width width (var Int count)
              stream raw_read pixels width*fb:pixel_size
              fb write_unmap x_position y count pixels
              if optimal
                (var Blob b) map pixels width*fb:pixel_size
                connection oraw b
            if optimal
              connection oraw close
              connection oraw open (cast "image_redraw" Ident) "fb" (cast x_position Int) (cast y_position Int) (cast x_position+width Int) (cast y_position+height Int) (cast "section" Ident) "display" close
          eif encoding=1
            if trace_encoding
              console "copy area" eol
            stream raw_read addressof:(var uInt16_hi src_x) uInt16_hi:size
            stream raw_read addressof:(var uInt16_hi src_y) uInt16_hi:size
            connection oraw open (cast "image_copy" Ident) "fb" (cast src_x Int) (cast src_y Int) (cast src_x+width Int) (cast src_y+height Int) "fb" (cast x_position Int) (cast y_position Int) close
          eif use_hextile and encoding=5
            if trace_encoding
              console "hextile " (cast width Int) " x " (cast height Int) eol
            if trace_compression
              rcount += height*width*fb:pixel_size
            var uInt32 background foreground color
            for (var Int base_y) y_position y_position+height-1 step 16
              var Int tile_y := min y_position+height-base_y 16
              for (var Int base_x) x_position x_position+width-1 step 16
                var Int tile_x := min x_position+width-base_x 16
                stream raw_read addressof:(var uInt8 code) 1
                if trace_compression
                  hcount += 1
                if (code .and. 1)<>0
                  if trace_encoding
                    console "  " base_x " " base_y ": " (cast code Int) " raw" eol
                  for (var Int y) base_y base_y+tile_y-1
                    var Address pixels := fb write_map base_x y tile_x tile_x (var Int count)
                    stream raw_read pixels tile_x*fb:pixel_size
                    if trace_compression
                      hcount += tile_x*fb:pixel_size
                    fb write_unmap base_x y count pixels
                else
                  if (code .and. 2)<>0
                    stream raw_read addressof:background fb:pixel_size
                    if trace_compression
                      hcount += fb pixel_size
                  if (code .and. 4)<>0
                    stream raw_read addressof:foreground fb:pixel_size
                    if trace_compression
                      hcount += fb pixel_size
                  for (var Int y) base_y base_y+tile_y-1
                    fb fill base_x y tile_x addressof:background
                  if (code .and. 8)<>0
                    stream raw_read addressof:(var uInt8 nb_subrec) 1
                    if trace_compression
                      hcount += 1
                    if trace_encoding
                      console "  " base_x " " base_y ": " (cast code Int) " " (cast nb_subrec Int) eol
                    for (var Int j) 0 nb_subrec-1
                      if (code .and. 16)<>0
                        stream raw_read addressof:color fb:pixel_size
                        if trace_compression
                          hcount += fb pixel_size
                      else
                        color := foreground
                      stream raw_read addressof:(var uInt8 x_and_y) 1
                      if trace_compression
                        hcount += 1
                      var Int delta_x := x_and_y\16 ; var Int delta_y := x_and_y .and. 15
                      stream raw_read addressof:(var uInt8 width_and_height) 1
                      if trace_compression
                        hcount += 1
                      var Int nb_x := width_and_height\16+1 ; var Int nb_y := (width_and_height .and. 15)+1
                      if trace_encoding
                        console "    " delta_x " " delta_y " " nb_x " " nb_y eol
                      if delta_x+nb_x>tile_x or delta_y+nb_y>tile_y
                        console "corrupted VNC redraw stream (3)" eol
                        stream configure "shutdown"
                        return
                      for (var Int y) base_y+delta_y base_y+delta_y+nb_y-1
                        fb fill base_x+delta_x y nb_x addressof:color
                  else
                    if trace_encoding
                      console "  " base_x " " base_y ": " (cast code Int) eol
            if optimal
              connection oraw open (cast "image_write_raw" Ident) "fb" (cast x_position Int) (cast y_position Int) (cast x_position+width Int) (cast y_position+height Int) body
              if trace_compression
                var Address previous := memory_zallocate width*fb:pixel_size null
                var Address cpr := memory_allocate 2*width*fb:pixel_size+4 null
              for (var Int y) y_position y_position+height-1
                var Address pixels := fb read_map x_position y width width (var Int count)
                (var Blob b) map pixels width*fb:pixel_size
                connection oraw b
                if trace_compression
                  pcount += pack4_encode pixels cpr fb:pixel_size width previous
                  memory_copy pixels previous width*fb:pixel_size
                fb read_unmap x_position y count pixels
              if trace_compression
                memory_free cpr
                memory_free previous
                console "  raw " rcount " hextile " hcount " pack4 " pcount " (" (string 100.0*hcount/rcount "fixed 0") "% " (string 100.0*pcount/hcount "fixed 0") "%)   [cr]"
              connection oraw close
              connection oraw open (cast "image_redraw" Ident) "fb" (cast x_position Int) (cast y_position Int) (cast x_position+width Int) (cast y_position+height Int) (cast "section" Ident) "display" close
          else
            console "corrupted VNC redraw stream (2 " (cast encoding Int) ")" eol
            stream configure "shutdown"
            return
        if optimal
          connection oraw close
        else
          context section_replay "display"
        connection flush anytime
        refresh_counter += 1
      eif message=2
        void # bell
      eif message=3
        for (var Int i) 1 3
          stream raw_read addressof:(var Byte drop) 1
        stream raw_read addressof:(var uInt32_hi length) uInt32_hi:size
        for (var Int i) 1 length
          stream raw_read addressof:(var Byte drop) 1
      else
        console "VNC unknown message " (cast message Int) eol


function kbd_map key -> c
  arg Str key ; arg Int c
  if key:len=1
    c := key:0 number
  eif key="enter"
    c := 0FF0Dh
  eif key="backspace"
    c := 0FF08h
  eif key="tab"
    c := 0FF09h
  eif key="escape"
    c := 0FF1Bh
  eif key="insert"
    c := 0FF63h
  eif key="delete"
    c := 0FFFFh
  eif key="home"
    c := 0FF50h
  eif key="end"
    c := 0FF57h
  eif key="pageup"
    c := 0FF55h
  eif key="pagedown"
    c := 0FF56h
  eif key="left"
    c := 0FF51h
  eif key="up"
    c := 0FF52h
  eif key="right"
    c := 0FF53h
  eif key="down"
    c := 0FF54h
  eif (key parse "F" (var Int i)) and i>=1 and i<=12
    c := 0FFBDh+i
  eif key="ctrl"
    c := 0FFE3h
  eif key="alt"
    c := 0FFE9h
  else
    c := undefined

method session send_event event key x y buttons
  arg_rw VncSession session ; arg Str event key ; arg Int x y ; arg Int buttons
  implicit session
    vnc_sem request
    var Str key2
    if (key parse word:"ctrl" any:key2) and key2<>""
      void
    eif (key parse word:"alt" any:key2) and key2<>""
      void
    else
      key2 := key
    var CBool shift := false
    if (event="press" or event="release") and (key parse "button" (var Int i)) or event="move"
      var uInt8 message := 5 ; stream raw_write addressof:message 1
      var Int b := buttons
      if event="press"
        b := b .or. 2^(i-1)
      eif event="release"
        b := b .and. .not. 2^(i-1)
      send_mouse x y b 
      send_refresh_request
      stream flush anytime
    eif event="character" or event="uncharacter"
      if osx
        if key2:len=1
          constant uppers "~!@#$%^&*()_+{}|:[dq]<>?"
          constant lowers "`1234567890-=[lb][rb]\;',./"
          var Int i := uppers search key2 -1
          if i>=0
            key2 := lowers i ; shift := true
          eif key2>="A" and key2<="Z"
            shift := true
      if shift
        send_key true 0FFE1h
      var Str32 ch := utf8_decode key2
      if ch:len<>1
        console "unexpected character length" eol
      eif ch:0:number>=128
        console "non ascii character " ch:0:number eol
      else
        # console (shunt shift "shift " "") (character ch:0:number) " (" ch:0:number ")" eol
        send_key (event="character") ch:0:number
      if shift
        send_key false 0FFE1h
      send_refresh_request
      stream flush anytime
    eif (event="press" or event="release") and key<>"shift"
      var Int k := kbd_map key2
      if k<>undefined
        send_key event="press" k
        send_refresh_request
        stream flush anytime
      eif event="press"
        console "unsupported key " key eol
    vnc_sem release
  

method session connect server password context -> status
  arg_rw VncSession session ; arg Str server password ; arg_rw UIServerContext context ; arg ExtendedStatus status
  implicit session
    if not (server eparse any:(var Str host) ":" (var Int display))
      host := server ; display := 0
    stream open "tcp://"+host+"/client/"+(string 5900+display) in+out+safe+noautopost
    var Str handshake := stream readline
    if (handshake 0 3)<>"RFB"
      return failure:"Failed to connect to the VNC server"
    stream writeline "RFB 003.003" ; stream flush anytime
    stream raw_read addressof:(var uInt32_hi auth) uInt32:size
    if auth=2
      stream raw_read addressof:(var (Array Byte 16) challenge) 16
      vncEncryptBytes addressof:challenge password
      stream raw_write addressof:(var (Array Byte 16) challenge) 16 ; stream flush anytime
      stream raw_read addressof:(var uInt32_hi ack) uInt32:size
      if ack<>0
        return failure:"Password is wrong"
    var uInt8 share := 1 ; stream raw_write addressof:share uInt8:size ; stream flush anytime
    stream raw_read addressof:(var uInt16_hi size_x) uInt16:size
    stream raw_read addressof:(var uInt16_hi size_y) uInt16:size
    stream raw_read addressof:(var VncPixelFormat pixel_format) VncPixelFormat:size
    stream raw_read addressof:(var uInt32_hi length) uInt32:size
    var Str name := repeat length " "
    stream raw_read name:characters name:len
    if false
      console "VNC screen " name " is " (cast size_x Int) " x " (cast size_y Int) " x " (cast pixel_format:bits_per_pixel Int) eol
      console "depth = " (cast pixel_format:depth Int) eol
      console "red max = " (cast pixel_format:red_max Int) eol
      console "green max = " (cast pixel_format:green_max Int) eol
      console "blue max = " (cast pixel_format:blue_max Int) eol
      console "red shift = " (cast pixel_format:red_shift Int) eol
      console "green shift = " (cast pixel_format:green_shift Int) eol
      console "blue shift = " (cast pixel_format:blue_shift Int) eol
  
    var uInt8 message := 0 ; stream raw_write addressof:message 1
    for (var Int i) 1 3
      var uInt8 padding := 0 ; stream raw_write addressof:padding 1
    pixel_format true_color_flag := 1
    pixel_format bits_per_pixel := 32
    pixel_format big_endian_flag := shunt processor_is_low_indian 0 1
    pixel_format true_color_flag := 1
    pixel_format red_max := 255
    pixel_format green_max := 255
    pixel_format blue_max := 255
    pixel_format red_shift := 16
    pixel_format green_shift := 8
    pixel_format blue_shift := 0
    stream raw_write addressof:pixel_format VncPixelFormat:size
  
    var uInt8 message := 2 ; stream raw_write addressof:message 1
    var uInt8 padding := 0 ; stream raw_write addressof:padding 1
    var uInt16_hi number_of_encodings := shunt use_hextile 3 2 ; stream raw_write addressof:number_of_encodings uInt16_hi:size
    if use_hextile
      var uInt32_hi encoding := 5 ; stream raw_write addressof:encoding uInt32_hi:size
    var uInt32_hi encoding := 1 ; stream raw_write addressof:encoding uInt32_hi:size
    var uInt32_hi encoding := 0 ; stream raw_write addressof:encoding uInt32_hi:size
    stream flush anytime
  
    fb setup (image_prototype 0 0 size_x/100*25.4 size_y/100*25.4 size_x size_y color_gamut:"bgr32") ""
    context section_replay "display"
    var Link:VncSession s :> session
    context ui_thread
      s screen_update context
    context ui_thread
      s timer_refresh
    status := success


#--------------------------------------------------------------------------


method session message msg
  arg_rw VncSession session ; arg Str msg
  implicit session
    ui section_overwrite "help"
      ui text msg
    ui flush
    
method session pause
  arg_rw VncSession session
  sleep 0.5
    
method session sync
  arg_rw VncSession session
  sleep 0.1
  if false
    while session:pending_refresh<>0
      console session:pending_refresh "    [cr]"
      sleep 0
    

method session script_begin path
  arg_rw VncSession session ; arg Str path
  implicit session
    if not (exists images_path:first)
      ui:connection oraw close
    images_path += path

method session script_end
  arg_rw VncSession session
  implicit session
    if (exists images_path:first)
      images_path remove images_path:last
      if not (exists images_path:first)
        ui:connection oraw open (cast "group" Ident) body
        message "done."


method session move x y
  arg_rw VncSession session ; arg Int x y
  implicit session
    message "move "+string:x+" "+string:y
    send_event "move" "" x y mouse_buttons
    sync
    mouse_x := x ; mouse_y := y
    pause


method session clic x y
  arg_rw VncSession session ; arg Int x y
  implicit session
    message "clic "+string:x+" "+string:y
    send_event "move" "" x y 0
    sync
    send_event "press" "button1" x y 0
    send_event "release" "button1" x y 0
    sync
    mouse_x := x ; mouse_y := y ; mouse_buttons := 0
    pause


method session doubleclic x y
  arg_rw VncSession session ; arg Int x y
  implicit session
    message "doubleclic "+string:x+" "+string:y
    send_event "move" "" x y 0
    send_event "press" "button1" x y 0
    send_event "release" "button1" x y 0
    send_event "press" "button1" x y 0
    send_event "release" "button1" x y 0
    sync
    mouse_x := x ; mouse_y := y ; mouse_buttons := 0
    pause


method session clic_down
  arg_rw VncSession session
  implicit session
    message "clic_down"
    send_event "press" "button1" mouse_x mouse_y 0
    sync
    mouse_buttons := 1
    pause

method session clic_up
  arg_rw VncSession session
  implicit session
    message "clic_down"
    send_event "release" "button1" mouse_x mouse_y 0
    mouse_buttons := 0
    pause
    sync

method session slide x0 y0 x1 y1 s
  arg_rw VncSession session ; arg Int x0 y0 x1 y1 ; arg Float s
  implicit session
    message "slide "+string:x0+" "+string:y0+" -> "+string:x1+" "+string:y1
    send_event "move" "" x0 y0 0
    sync
    send_event "press" "button1" x0 y0 0
    sync
    sleep s
    send_event "move" "" x1 y1 1
    sync
    send_event "release" "button1" x1 y1 1
    sync
    mouse_x := x1 ; mouse_y := y1 ; mouse_buttons := 0
    pause


method session typein txt x y
  arg_rw VncSession session ; arg Str txt ; arg Int x y
  implicit session
    message "typein "+string:txt+(shunt x<>undefined and y<>undefined " at "+string:x+" "+string:y "")
    if x<>undefined and y<>undefined
      send_event "move" "" x y mouse_buttons
      sync
      mouse_x := x ; mouse_y := y
    for (var Int i) 0 txt:len-1
      if (txt i 1)="[lf]"
        send_event "press" "enter" mouse_x mouse_y mouse_buttons
      else
        send_event "character" (txt i 1) mouse_x mouse_y mouse_buttons 
    sync
    pause

method session typein txt
  arg_rw VncSession session ; arg Str txt
  session typein txt undefined undefined
  

method session key k x y
  arg_rw VncSession session ; arg Str k ; arg Int x y
  implicit session
    message "key "+string:k+(shunt x<>undefined and y<>undefined " at "+string:x+" "+string:y "")
    if x<>undefined and y<>undefined
      send_event "move" "" x y mouse_buttons
      sync
      mouse_x := x ; mouse_y := y
    var Str k2
    if (k parse word:"ctrl" any:k2) and k2<>""
      send_event "press" "ctrl" mouse_x mouse_y mouse_buttons
      key k2 undefined undefined
      send_event "release" "ctrl" mouse_x mouse_y mouse_buttons
    eif (k parse word:"alt" any:k2) and k2<>"" or (k parse word:"apple" any:k2) and k2<>""
      send_event "press" "alt" mouse_x mouse_y mouse_buttons
      key k2 undefined undefined
      send_event "release" "alt" mouse_x mouse_y mouse_buttons
    eif k:len=1
      send_event "character" k mouse_x mouse_y mouse_buttons
      send_event "uncharacter" k mouse_x mouse_y mouse_buttons
    else
      send_event "press" k mouse_x mouse_y mouse_buttons
      send_event "release" k mouse_x mouse_y mouse_buttons
    sync
    pause

method session key k
  arg_rw VncSession session ; arg Str k
  session key k undefined undefined
  

method session wait images timeout x0 y0 x1 y1 -> image
  arg_rw VncSession session ; arg Str images ; arg Float timeout ; arg_w Int x0 y0 x1 y1 ; arg Str image
  implicit session
    message "waiting for '"+images+"'"
    var Dictionary patterns
    var Str all := images
    while all<>""
      if not (all parse any:(var Str name) _ any:(var Str remain))
        name := all ; remain := ""
      var Str filename := name
      if (filename search "." -1)=(-1)
        filename += ".png"
      if (filename search "/" -1)=(-1) and (exists images_path:last)
        filename := images_path:last+filename
      if (images_cache first filename)<>null
        patterns insert name true (images_cache first filename)
      else
        var Link:ImagePixmap rough :> new ImagePixmap
        if (rough load filename "")=success
          var Link:ImageConvert final :> new ImageConvert
          final bind rough fb:gamut ""
          var Link:ImagePixmap copy :> new ImagePixmap
          copy setup final ""
          var Address buffer := memory_allocate copy:line_size null
          for (var Int y) 0 copy:size_y-1
            final read 0 y final:size_x buffer
            copy write 0 y copy:size_x buffer
          memory_free buffer
          images_cache insert filename true addressof:copy
          patterns insert name true addressof:copy
        else
          console "failed to load " filename eol
      all := remain
    var DateTime start := datetime
    var Int counter := refresh_counter-1
    while datetime:seconds-start:seconds<timeout
      if refresh_counter<>counter
        counter := refresh_counter
        each pattern patterns type ImagePixmap getkey id
          part scan_pattern
            var Address corner := pattern pixel 0 0
            var Int ps := pattern pixel_size
            for (var Int y) 0 fb:size_y-pattern:size_y
              var Address adr := fb pixel 0 y
              for (var Int x) 0 fb:size_x-pattern:size_x
                part scan_position
                  if (memory_different adr 3 corner 3)
                    leave scan_position
                  for (var Int i) 0 (min pattern:size_x pattern:size_y)-1
                    if (memory_different (fb pixel x+i y+i) 3 (pattern pixel i i) 3)
                      leave scan_position
                  for (var Int j) 0 pattern:size_y-1
                    for (var Int i) 0 pattern:size_x-1
                      if (memory_different (fb pixel x+i y+j) 3 (pattern pixel i j) 3)
                        leave scan_position
                  x0 := x ; y0 := y ; x1 := x+pattern:size_x ; y1 := y+pattern:size_y
                  return id
                adr := adr translate Byte ps
      sleep 0
    message "timeout waiting '"+images+"'"
    x0 := undefined ; y0 := undefined ; x1 := undefined ; y1 := undefined ; image := ""
    
method session wait images timeout x y -> image
  arg_rw VncSession session ; arg Str images ; arg Float timeout ; arg_w Int x y ; arg Str image
  image := session wait images timeout (var Int x0) (var Int y0) (var Int x1) (var Int y1)
  if x0<>undefined
    x := (x0+x1)\2 ; y := (y0+y1)\2
  else
    x := undefined ; y := undefined

method session wait images timeout -> image
  arg_rw VncSession session ; arg Str images ; arg Float timeout ; arg Str image
  image := session wait images timeout (var Int x0) (var Int y0) (var Int x1) (var Int y1)


method session ocr text x0 y0 x1 y1 -> status
  arg_rw VncSession session ; arg Str text ; arg_w Int x0 y0 x1 y1 ; arg ExtendedStatus status
  implicit session
    message "ocr '"+text+"'"
    ocr_image fb ocr_fonts "answer "+string:text+" "+ocr_options (var List:OCRResult result)
    var Pointer:OCRResult r :> result first
    if exists:r and not exists:(result next r) and r:text=text
      x0 := r x0 ; y0 := r y0 ; x1 := r x1 ; y1 := r y1
      status := success
      status message := string r:uncertainty
    eif exists:r and not exists:(result next r)
      x0 := r x0 ; y0 := r y0 ; x1 := r x1 ; y1 := r y1
      status := failure "fuzzy '"+r:text+"'"
    eif exists:r
      x0 := r x0 ; y0 := r y0 ; x1 := r x1 ; y1 := r y1
      status := failure "ambigious"
    else
      x0 := undefined ; y0 := undefined ; x1 := undefined ; y1 := undefined
      status := failure "not found"
    if ocr_trace
      each r result
        console "  " r:x0 " " r:y0 " " r:x1 " " r:y1 " '" r:text "' " r:uncertainty eol
      console "ocr '" text "' -> " (shunt status=success "yes" "no") " " x0 " " y0 " " x1 " " y1 " (" status:message ")" eol
    message "ocr '"+text+"' -> "+(shunt status=success "yes" "no")+" "+string:x0+" "+string:y0+" "+string:x1+" "+string:y1+" ("+status:message+")"
    pause

method session ocr text x y -> status
  arg_rw VncSession session ; arg Str text ; arg_w Int x y ; arg ExtendedStatus status
  status := session ocr text (var Int x0) (var Int y0) (var Int x1) (var Int y1)
  if x0<>undefined
    x := (x0+x1)\2 ; y := (y0+y1)\2
  else
    x := undefined ; y := undefined
  

method session ocr text timeout x0 y0 x1 y1 -> status
  arg_rw VncSession session ; arg Str text ; arg Float timeout ; arg_w Int x0 y0 x1 y1 ; arg ExtendedStatus status
  implicit session
    var DateTime start := datetime
    var Int counter := refresh_counter-1
    while datetime:seconds-start:seconds<timeout
      if refresh_counter<>counter
        status := ocr text x0 y0 x1 y1
        if status=success
          return
      sleep 0

method session ocr text timeout x y -> status
  arg_rw VncSession session ; arg Str text ; arg Float timeout ; arg_w Int x y ; arg ExtendedStatus status
  status := session ocr text timeout (var Int x0) (var Int y0) (var Int x1) (var Int y1)
  if x0<>undefined
    x := (x0+x1)\2 ; y := (y0+y1)\2
  else
    x := undefined ; y := undefined
 

method session ocr_clic text -> status
  arg_rw VncSession session ; arg Str text ; arg ExtendedStatus status
  implicit session
    status := ocr text (var Int x) (var Int y)
    if status=success
      clic x y


#--------------------------------------------------------------------------


ui_function vnc_client server0 password0 options0
  arg Str server0 password0 options0
  ovar VncSession session
  implicit session
    ui :> context
    window left
      section "menu" dynamic
        button "login" key "alt l"
          window top
            input "Server: " (ovar Str server) ; eol
            input "Password: " (ovar Str password) password ; eol
            select "VNC server is OSX: " session:osx
              option "yes" "true"
              option "no" "false"
            eol
            button "connect" key "alt c"
              var ExtendedStatus es := connect server password context
              if es=success
                action := "live"
                section_replay "menu"
              else
                message "FAILED: "+es:message
              window top
                void
            button "escape" key "escape"
              window top
                void
        eol
        button "live" key "alt i" selected action="live" help "Live operation."
          if stream:is_open
            action := "live"
          window top
            void
          section_replay "menu"
        eol
        button "screenshot" key "alt s" selected action="screenshot" help "Record a screenshort."
          action := "screenshot"
          section_replay "menu"
          window top
            input "Image file name: " image_filename
            button "escape" key "escape"
              action := ""
              window top
                void
              section_replay "menu"
          message "Fill in the file name, then select the area of the screen you want to store."
        eol
        button "OCR test" key "alt t" selected action="OCR" help "Test OCR capabilities."
          action := "OCR"
          section_replay "menu"
          window top
            ovar Str opt
            input "Text to find: " (ovar Str pattern)
            button "find" key "alt f"
              var Str memo := ocr_options
              ocr_options := opt
              var ExtendedStatus es := ocr pattern (var Int px0) (var Int py0) (var Int px1) (var Int py1)
              message ""
              ocr_options := memo
              section_overwrite "result"
                if es=success
                  text "found at "+string:px0+" "+string:py0+" "+string:px1+" "+string:py1+" ("+(string px1-px0)+"x"+(string py1-py0)+" pixels"+(shunt (es:message parse (var Float u)) " uncertainty "+(string u*100 "fixed 0")+"%" es:message<>"" " "+es:message "")+")"
                else
                  text "not found ("+es:message+")"
            button "escape" key "escape"
              action := ""
              window top
                void
              section_replay "menu"
            eol
            input "OCR options: " (ovar Str opt) help "See code about options that may help the OCR."
            eol
            section "result" inside
              void
           message "Fill in the pattern, then press 'find' button."
        eol
        button "exit" key "alt x"
          session:stream safe_configure "shutdown"
          url_return
        eol
        eol
        text "Scripts:"
        eol
        button "american" key "alt a" help "set American keyboard layout"
          script_begin "/pliant/protocol/vnc/images/"
          if false # absolute
            slide 877 11 877 38 0.5
          else # relative
            if (wait "french" 1 (var Int x) (var Int y))="french"
              move x y
              clic_down
              if (wait "american" 2 (var Int x) (var Int y))="american"
                move x y
                clic_up
          script_end
        eol
        button "X11 on" key "alt n" help "configure X11"
          script_begin "/pliant/protocol/vnc/images/"
          if (wait "x11" 1 (var Int x) (var Int y))="x11"
            clic x y
            if (wait "xterm" 15 (var Int x) (var Int y))="xterm"
              clic x+50 y+50
              typein "xhost +10.107.2.2[lf]"
              sleep 2
              typein "exit[lf]"
            else
              key "apple n"
              if (wait "xterm" 5 (var Int x) (var Int y))="xterm"
                clic x+50 y+50
                typein "xhost +10.107.2.2[lf]"
                sleep 2
                typein "exit[lf]"
          script_end
        eol
        button "X11 off" key "alt f" help "a tiny OCR based sample"
          script_begin "/pliant/protocol/vnc/images/"
          if (ocr_clic "X11")=success
            if (ocr_clic "Quit")=success
              console "yes !" eol
          script_end
        eol
        button "Type in" key "alt y" help "type in sample"
          window top
            input "Text to type: " (ovar Str txt) multiline
            button "go" key "alt g"
              window top
                void
              script_begin "/pliant/protocol/vnc/images/"
              typein txt
              script_end
            button "escape" key "escape"
              window top
                void
    window main
      section "hook"
        hook
          section "display" dynamic
            image_define "fb" session:fb
            image_inline "fb"
        event
          var Int ix := cast pointer_x/25.4*100 Int
          var Int iy := cast pointer_y/25.4*100 Int
          if event="press" and (key parse "button" any)
            focus_set "hook" 0
          if action="live"
            send_event event key ix iy buttons
          eif action="screenshot" and event="press" and key="button1"
            selected_x0 := ix ; selected_y0 := iy
          eif action="screenshot" and event="release" and key="button1"
            if allowed:"administrator"
              selected_x1 := ix ; selected_y1 := iy
              if selected_x0>=0 and selected_y0>=0 and selected_x1>selected_x0 and selected_y1>selected_y0 and selected_x1<=fb:size_x and selected_y1<=fb:size_y
                var Link:ImagePixmap rough :> new ImagePixmap
                rough setup (image_prototype selected_x0/100*25.4 selected_y0/100*25.4 selected_x1/100*25.4 selected_y1/100*25.4 selected_x1-selected_x0 selected_y1-selected_y0 fb:gamut) ""
                var Address buffer := memory_allocate rough:line_size null
                for (var Int y) selected_y0 selected_y1-1
                  fb read selected_x0 y selected_x1-selected_x0 buffer
                  rough write 0 y-selected_y0 selected_x1-selected_x0 buffer
                memory_free buffer
                var Link:ImageConvert final :> new ImageConvert
                final bind rough color_gamut:"rgb" ""
                if (final save image_filename "")=success
                  message "'"+image_filename+"' has been recorded"
                else
                  message "Failed to record '"+image_filename+"'"
              else
                message "Incorrect area selected."
            else
              message "Only administrator is allowed to do that."
        move
          var Int ix := cast pointer_x/25.4*100 Int
          var Int iy := cast pointer_y/25.4*100 Int
          section_overwrite "help"
            text string:ix+" "+string:iy
          if action="live"
            send_event event key ix iy buttons
    window bottom
      section "help"
        void
    if password0<>""
      if (options0 option "osx")
        osx := true
      if (connect server0 password0 context)=success
        action := "live"
        section_replay "menu"

              
export '. vnc_client'