Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/console/x11.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/language/type/text/str8.pli"
module "prototype.pli"
module "x11_api.pli"


function rgb_color r g b -> rgb
  arg Int r g b rgb
  check r>=0 and r<256 and g>=0 and g<256 and b>=0 and b<256
  rgb := r+g*2^8+b*2^16

constant ground_color (rgb_color 248 248 248)
constant trace false
constant wheel true


gvar Pointer:XDisplay display :> XOpenDisplay ":0.0"
if not exists:display
  error "Failed to open X11 display"
gvar Pointer:XScreen screen :> (display:screens translate XScreen display:default_screen) map XScreen
gvar Pointer:XVisual visual :> screen root_visual
if screen:root_depth<>24
  error "Pliant requires X11 to work in truecolor mode (either 24 or 32 bits per pixel)"
gvar Int atom_utf8


function x11_gamut_name -> name
  arg Str name
  name := "rgb"
  if visual:red_mask=255*2^16
    name := shunt name="rgb" "bgr" "rgb"
  if (shunt processor_is_low_indian LSBFirst MSBFirst)<>display:byte_order
    name := shunt name="rgb" "bgr" "rgb"
  check display:bitmap_unit=24 or display:bitmap_unit=32
  if display:bitmap_unit=32
    name += "32"


function x11_color rgb -> c
  arg Int rgb ; arg Str c
  function hexa2 i -> h2
    arg Int i ; arg Str h2
    h2 := right (string i "radix 16") 2 "0"
  c := "rgb:"+(hexa2 rgb%256)+"/"+(hexa2 rgb\256%256)+"/"+(hexa2 rgb\256^2)

if (XAllocNamedColor display screen:cmap x11_color:ground_color (gvar XColor x11_ground_exact) (gvar XColor x11_ground))=0
  error "Failed to allocate X11 ground color"
atom_utf8 := XInternAtom display "UTF8_STRING" false


type ConsoleX11
  field Pointer:XDisplay display
  field Pointer:XScreen screen
  field Pointer:XVisual visual
  field Int atom_utf8
  field XWindow window
  field XGC gc
  field Int size_x size_y
  field Sem sem
  field XEvent ev
  field Int lock_x lock_y <- undefined
  field CBool locked <- false
  field Link:Function clipboard_fun ; field Address clipboard_param
  field CBool osx

ConsolePrototype maybe ConsoleX11


method c x11_gamut_name -> name
  arg ConsoleX11 c ; arg Str name
  name := "rgb"
  if c:visual:red_mask=255*2^16
    name := shunt name="rgb" "bgr" "rgb"
  check c:display:bitmap_unit=24 or c:display:bitmap_unit=32
  if c:display:bitmap_unit=32
    name += "32"


method c open p options -> status
  oarg_rw ConsoleX11 c ; arg ImagePrototype p ; arg Str options ; arg ExtendedStatus status
  c osx := options option "osx"

  var Str display := options option "display" Str ":0.0"
  c display :> XOpenDisplay display
  if not (exists c:display)
    return (failure "Failed to open X11 display '"+display+"'")
  c screen :> c:display:screens map XScreen c:display:default_screen
  c visual :> c:screen root_visual
  if c:screen:root_depth<>24
    XCloseDisplay c:display
    return failure:"Pliant requires X11 to work in truecolor mode (either 24 or 32 bits per pixel)"

  if (XAllocNamedColor c:display c:screen:cmap x11_color:ground_color (var XColor x11_ground_exact) (var XColor x11_ground))=0
    return failure:"Failed to allocate X11 ground color"
  c atom_utf8 := XInternAtom c:display "UTF8_STRING" false

  var XSetWindowAttributes a
  a background_pixel := x11_ground pixel
  a override_redirect := false
  a event_mask := PointerMotionMask+ButtonPressMask+ButtonReleaseMask+KeyPressMask+KeyReleaseMask+ExposureMask+StructureNotifyMask
  var uInt mask := CWBackPixel+CWBorderPixel+CWOverrideRedirect+CWEventMask
  c size_x := p size_x ; c size_y := p size_y
  if not (options option "size_x") and display:nscreens>display:default_screen
    var Pointer:XScreen screen :> display:screens map XScreen display:default_screen
  if not (options option "size_x") and c:display:nscreens>c:display:default_screen
    if (options option "fullscreen")
      c size_x := screen width
      c size_y := screen height
      c size_x := c:screen width
      c size_y := c:screen height
      a override_redirect := true
      a cursor := XCreateFontCursor display (shunt (options option "cross") 130 68)
      a cursor := XCreateFontCursor c:display (shunt (options option "cross") 130 68)
      mask += CWCursor
    eif (options option "autosize")
      c size_y := c:screen:height-100
      c size_x := min c:screen:width-100 c:size_y*4\5
    else
      c size_y := screen:height-100
      c size_x := min screen:width-100 c:size_y*4\5
  c window := XCreateWindow display screen:root 0 0 c:size_x c:size_y 0 screen:root_depth InputOutput screen:root_visual mask a
  XStoreName display c:window (options option "label" Str)
  XMapWindow display c:window
  c gc := XCreateGC display c:window 0 (var XGCValues gcvalues)
      c size_x := p size_x
      c size_y := p size_y
  c window := XCreateWindow c:display c:screen:root 0 0 c:size_x c:size_y 0 c:screen:root_depth InputOutput c:screen:root_visual mask a
  XStoreName c:display c:window (options option "label" Str)
  XMapWindow c:display c:window
  c gc := XCreateGC c:display c:window 0 (var XGCValues gcvalues)
  if (options option "fullscreen")
    XSetInputFocus display c:window 0 0
    XSetInputFocus c:display c:window 0 0
  status := success


method c query -> p
  oarg_rw ConsoleX11 c ; arg ImagePrototype p
  p := image_prototype 0 0 c:size_x/75*25.4 c:size_y/75*25.4 c:size_x c:size_y color_gamut:x11_gamut_name
  p := image_prototype 0 0 c:size_x/75*25.4 c:size_y/75*25.4 c:size_x c:size_y (color_gamut c:x11_gamut_name)


method c sem_request
  arg_rw ConsoleX11 c
  if c:sem:nowait_request
    return
  while true
    var XClientMessageEvent ev
    memory_clear addressof:ev XClientMessageEvent:size
    ev type := ClientMessage
    ev window := c window
    ev format := 8
    XSendEvent display c:window false 0 (addressof:ev map XEvent)
    XFlush display
    XSendEvent c:display c:window false 0 (addressof:ev map XEvent)
    XFlush c:display
    sleep 0
    if c:sem:nowait_request
      return
    var DateTime start := datetime
    while datetime:seconds-start:seconds<0.5
      if c:sem:nowait_request
        return
      sleep 0.01


method c paint img tx ty
  oarg_rw ConsoleX11 c ; oarg_rw ImagePrototype img ; arg Int tx ty
  if img:size_x>2048 or img:size_y>2048
    error "X11 paint overflow"
  var Address linebuf := memory_allocate img:line_size null
  var XImage ximg
  ximg width := img size_x
  ximg height := 1
  ximg xoffset := 0
  ximg format := ZPixmap
  ximg byte_order := display byte_order
  check display:bitmap_unit=img:pixel_size*8
  ximg bitmap_unit := display bitmap_unit
  ximg bitmap_bit_order := display bitmap_bit_order
  ximg bitmap_pad := display bitmap_pad
  ximg depth := screen root_depth
  ximg byte_order := shunt processor_is_low_indian LSBFirst MSBFirst # c:display byte_order
  check c:display:bitmap_unit=img:pixel_size*8
  ximg bitmap_unit := c:display bitmap_unit
  ximg bitmap_bit_order := c:display bitmap_bit_order
  ximg bitmap_pad := c:display bitmap_pad
  ximg depth := c:screen root_depth
  ximg bytes_per_line := img line_size
  ximg bits_per_pixel := img:pixel_size*8
  ximg red_mask := visual red_mask
  ximg green_mask := visual green_mask
  ximg blue_mask := visual blue_mask
  ximg red_mask := c:visual red_mask
  ximg green_mask := c:visual green_mask
  ximg blue_mask := c:visual blue_mask
  c sem_request
  if not (XInitImage ximg)
    error "Failed to setup X11 image"
  for (var Int iy) 0 img:size_y-1
    var Address adr := img read_map 0 iy img:size_x img:size_x (var Int count)
    if adr<>null
      ximg data := adr
      if (XPutImage display c:window c:gc ximg 0 0 tx ty+iy img:size_x 1)<>0
      if (XPutImage c:display c:window c:gc ximg 0 0 tx ty+iy img:size_x 1)<>0
        error "Failed to draw X11 image"
      img read_unmap 0 iy count adr
    else
      img read 0 iy img:size_x linebuf
      ximg data := linebuf
      if (XPutImage display c:window c:gc ximg 0 0 tx ty+iy img:size_x 1)<>0
      if (XPutImage c:display c:window c:gc ximg 0 0 tx ty+iy img:size_x 1)<>0
        error "Failed to draw X11 image"
  c:sem release
  memory_free linebuf


method c copy x0 y0 x1 y1 xx yy
  oarg_rw ConsoleX11 c ; arg Int x0 y0 x1 y1 xx yy
  if x1-x0<0 or y1-y0<0 or x1-x0>2048 or y1-y0>2048
    error "X11 copy overflow "+string:x0+" "+string:y0+" "+string:x1+" "+string:y1
  c sem_request
  XCopyArea display c:window c:window c:gc x0 y0 x1-x0 y1-y0 xx yy
  XCopyArea c:display c:window c:window c:gc x0 y0 x1-x0 y1-y0 xx yy
  c:sem release


function x11_keyboard_mapping id -> key
function x11_keysym_mapping id -> key
  arg Int id ; arg Str key
  if id=XK_Return
    key := "enter"
  eif id=XK_BackSpace
    key := "backspace"
  eif id=XK_Tab or id=XK_ISO_Left_Tab
    key := "tab"
  eif id=XK_Escape
    key := "escape"
  eif id=XK_Left
    key := "left"
  eif id=XK_Up
    key := "up"
  eif id=XK_Right
    key := "right"
  eif id=XK_Down
    key := "down"
  eif id=XK_Page_Up
    key := "pageup"
  eif id=XK_Page_Down
    key := "pagedown"
  eif id=XK_Home
    key := "home"
  eif id=XK_End
    key := "end"
  eif id=XK_Insert
    key := "insert"
  eif id=XK_Delete
    key := "delete"
  eif id=XK_Pause
    key := "pause"
  eif id=XK_Print
    key := "print"
  eif id=XK_Shift_L or id=XK_Shift_R
    key := "shift"
  eif id=XK_Control_L or id=XK_Control_R
    key := "ctrl"
  eif id=XK_Alt_L or id=XK_Alt_R
    key := "alt"
  eif id>=XK_F1 and id<=XK_F12
    key := "F"+(string id-XK_F0)
  else
    # console "X11 key id is " id eol
    key := ""

function x11_keycode_mapping code -> key
  arg Int code ; arg Str key
  if code=115
    key := "windows"
  eif code=117
    key := "menu"
  else
    key := ""

function clipboard_content param fun -> text
  arg Address param ; arg Function fun ; arg Str text
  indirect

method c event key buttons x_or_x0 y_or_y0 x1 y1 options -> event
  oarg_rw ConsoleX11 c ; arg_w Str key ; arg_w Int buttons x_or_x0 y_or_y0 x1 y1 ; arg_w Str options ; arg Str event
  key := "" ; buttons := undefined ; x_or_x0 := undefined ; y_or_y0 := undefined ; x1 := undefined ; y1 := undefined ; options := "" ; event := ""
  c:sem request
  part wait_for_event
    XNextEvent display (var XEvent ev)
    XNextEvent c:display (var XEvent ev)
    if ev:type=Expose or ev:type=GraphicsExpose
      var Pointer:XExposeEvent expose :> addressof:ev map XExposeEvent
      if trace
        console "redraw " expose:x " " expose:y " " expose:x+expose:width " " expose:y+expose:height " (" expose:count ")" eol
      x_or_x0 := expose x ; y_or_y0 := expose y ; x1 := expose:x+expose:width ; y1 := expose:y+expose:height
      event := "redraw"
      while (XCheckTypedEvent display GraphicsExpose ev)
      while (XCheckTypedEvent c:display GraphicsExpose ev)
        x_or_x0 := min x_or_x0 expose:x
        y_or_y0 := min y_or_y0 expose:y
        x1 := max expose:x+expose:width x1
        y1 := max expose:y+expose:height y1
    eif ev:type=NoExpose
      if trace
        console "noexpose" eol
    eif ev:type=KeyPress or ev:type=KeyRelease
      var Pointer:XKeyEvent k :> addressof:ev map XKeyEvent
      x_or_x0 := k x ; y_or_y0 := k y
      buttons := k:state\256%7
      key := "                     "
      buttons := (shunt (k:state .and. 100h)<>0 1 0)+(shunt (k:state .and. 400h)<>0 2 0)+(shunt (k:state .and. 200h)<>0 4 0)
      var Int ch := 0
      memory_clear addressof:(var XComposeStatus cstatus) XComposeStatus:size
      XLookupString k key:characters key:len (var XKeySym keysym) cstatus
      XLookupString k addressof:ch Int:size (var XKeySym keysym) cstatus
      options := "keycode "+(string k:keycode)
      if keysym:id>0 and keysym:id<0F000h
      if { key := x11_keysym_mapping keysym:id ; key<>"" }
        event := shunt ev:type=KeyPress "press" "release"
      eif { key := x11_keycode_mapping k:keycode ; key<>"" }
        event := shunt ev:type=KeyPress "press" "release"
      eif keysym:id>0 and keysym:id<0F000h
        key := utf8_encode (character32 keysym:id)
        event := shunt ev:type=KeyPress "character" "uncharacter"
      eif ch>0
        key := utf8_encode character32:ch
        event := shunt ev:type=KeyPress "character" "uncharacter"
      else
        key := x11_keyboard_mapping keysym:id
        event := shunt ev:type=KeyPress "press" "release"
        key := ""
      if key=""
        if trace
          console "key " k:keycode " state " k:state " keysym " keysym:id " character " ch " -> rejected" eol
        restart wait_for_event
      if event="press" or event="release" or ((k:state .and. 12)<>0 and key:len=1 and ((key>="a" and key<="z") or (key>="A" and key<="Z") or (key>="0" and key<="1")))
      if event="press" or event="release" or ((k:state .and. 4+8+(shunt c:osx 16 0))<>0 and key:len=1 and ((key>="a" and key<="z") or (key>="A" and key<="Z") or (key>="0" and key<="9")))
        event := shunt event="character" "press" event="uncharacter" "release" event
        if (k:state .and. 8)<>0 and key<>"alt"
        if (k:state .and. 8+(shunt c:osx 16 0))<>0 and key<>"alt"
          key := "alt "+key
        if (k:state .and. 4)<>0 and key<>"ctrl"
          key := "ctrl "+key
        if (k:state .and. 1)<>0 and key<>"shift"
          key := "shift "+key
      if trace
        console "key " k:keycode " state " k:state " keysym " keysym:id " -> " event " " key eol
        console "key " k:keycode " state " k:state " keysym " keysym:id " character " ch " -> " event " " key eol
    eif ev:type=ButtonPress or ev:type=ButtonRelease
      var Pointer:XButtonEvent button :> addressof:ev map XButtonEvent
      if trace
        console "button " button:button " state " button:state " position " button:x " " button:y eol
      x_or_x0 := button x ; y_or_y0 := button y
      buttons := button:state\256%7
      if button:button>=1 and button:button<=3
        key := "button"+(string button:button)
        event := shunt ev:type=ButtonPress "press" "release"
      buttons := (shunt (button:state .and. 100h)<>0 1 0)+(shunt (button:state .and. 400h)<>0 2 0)+(shunt (button:state .and. 200h)<>0 4 0)
      key := shunt button:button=1 "button1" button:button=3 "button2" button:button=2 "button3" ""
      event := shunt key="" "" ev:type=ButtonPress "press" "release"
      c lock_x := x_or_x0 ; c lock_y := y_or_y0
      if wheel and (button:button=4 or button:button=5) and ev:type=ButtonPress
        event := "scroll" ; key := "wheel"
        x_or_x0 := 0 ; y_or_y0 := shunt button:button=4 -1 1
        x1 := button x ; y1 := button y
    eif ev:type=MotionNotify
      while (XCheckTypedEvent display MotionNotify ev)
      while (XCheckTypedEvent c:display MotionNotify ev)
        void
      var Pointer:XMotionEvent motion :> addressof:ev map XMotionEvent
      if c:locked
        event := "scroll"
        var uInt none := 0
        x_or_x0 := motion:x-c:lock_x ; y_or_y0 := motion:y-c:lock_y
        if x_or_x0=0 and y_or_y0=0
          restart wait_for_event
        x1 := c lock_x ; y1 := c lock_y
        XWarpPointer display (addressof:none map XWindow) (addressof:none map XWindow) 0 0 0 0 -x_or_x0 -y_or_y0
        XMaskEvent display ButtonMotionMask ev
        XWarpPointer c:display (addressof:none map XWindow) (addressof:none map XWindow) 0 0 0 0 -x_or_x0 -y_or_y0
        XMaskEvent c:display ButtonMotionMask ev
      else
        event := "move"
        x_or_x0 := motion x ; y_or_y0 := motion y
      buttons := motion:state\256%7
      buttons := (shunt (motion:state .and. 100h)<>0 1 0)+(shunt (motion:state .and. 400h)<>0 2 0)+(shunt (motion:state .and. 200h)<>0 4 0)
    eif ev:type=ConfigureNotify
      var Pointer:XConfigureEvent configure :> addressof:ev map XConfigureEvent
      x_or_x0 := configure width ; y_or_y0 := configure height
      while (XCheckTypedEvent display ConfigureNotify ev)
      while (XCheckTypedEvent c:display ConfigureNotify ev)
        var Pointer:XConfigureEvent configure :> addressof:ev map XConfigureEvent
        x_or_x0 := configure width ; y_or_y0 := configure height
      event := "resize"
    eif ev:type=ClientMessage
      c:sem release
      sleep 0.01
      c:sem request
    eif ev:type=SelectionRequest
      var Pointer:XSelectionRequestEvent sre :> addressof:ev map XSelectionRequestEvent
      var CBool ok := sre:selection=XA_PRIMARY and (sre:target=atom_utf8 or sre:target=XA_STRING) and (addressof c:clipboard_fun)<>null
      var CBool ok := sre:selection=XA_PRIMARY and (sre:target=c:atom_utf8 or sre:target=XA_STRING) and (addressof c:clipboard_fun)<>null
      if ok
        var Int prop := sre property
        var Str text := clipboard_content c:clipboard_param c:clipboard_fun
        if sre:target=atom_utf8
          XChangeProperty display sre:requestor prop XA_STRING 8 PropModeReplace text:characters text:len
        if sre:target=c:atom_utf8
          XChangeProperty c:display sre:requestor prop XA_STRING 8 PropModeReplace text:characters text:len
        else
          var Str8 text8 := text
          XChangeProperty display sre:requestor prop XA_STRING 8 PropModeReplace text8:characters text8:len
          XChangeProperty c:display sre:requestor prop XA_STRING 8 PropModeReplace text8:characters text8:len
      var XSelectionEvent se
      se type := SelectionNotify
      se serial := 0
      se send_event := true
      se display :> display
      se display :> c:display
      se requestor := sre requestor
      se selection := sre selection
      se target := sre target
      se property := shunt ok prop 0
      se time := sre time
      XSendEvent display sre:requestor false 0 (addressof:se map XEvent)
      XSendEvent c:display sre:requestor false 0 (addressof:se map XEvent)
    eif ev:type=SelectionClear
      c clipboard_fun :> null map Function
    eif trace
      console "unknown event " ev:type eol
    if event=""
      restart wait_for_event
  c:sem release
  # FIXME: buttons seems to be wrong


method c lock_pointer locked
  oarg_rw ConsoleX11 c ; arg CBool locked
  c locked := locked


method c close
  oarg_rw ConsoleX11 c
  XFreeGC display c:gc
  XDestroyWindow display c:window
  XFreeGC c:display c:gc
  XDestroyWindow c:display c:window
  XCloseDisplay c:display


method c clipboard_export fun param
  oarg_rw ConsoleX11 c ; arg Function fun ; arg Address param
  c:sem request
  c clipboard_fun :> fun
  c clipboard_param := param
  XSetSelectionOwner display XA_PRIMARY c:window 0
  (var XWindow none) id := 0
  XSetSelectionOwner c:display XA_PRIMARY (shunt exists:fun c:window none) 0
  c:sem release


method c clipboard_import text -> status
  oarg_rw ConsoleX11 c ; arg_w Str text ; arg Status status
  c:sem request
  text := ""
  status := failure
  if not (exists c:clipboard_fun)
    for (var Int lap) 1 2
      constant prop XA_STRING
      var Int req_type := shunt lap=1 atom_utf8 XA_STRING
      XConvertSelection display XA_PRIMARY req_type prop c:window 0
      var Int req_type := shunt lap=1 c:atom_utf8 XA_STRING
      XConvertSelection c:display XA_PRIMARY req_type prop c:window 0
      part wait
        for (var Int lap) 1 50
          if (XCheckTypedEvent display SelectionNotify (var XEvent ev))
          if (XCheckTypedEvent c:display SelectionNotify (var XEvent ev))
            if (addressof:ev map XSelectionEvent):property=0
              leave wait
            XGetWindowProperty display c:window prop 0 2^24 true req_type (var Int actual_type) (var Int actual_format) (var Int size) (var Int bytes_after) (var Address adr)
            XGetWindowProperty c:display c:window prop 0 2^24 true req_type (var Int actual_type) (var Int actual_format) (var Int size) (var Int bytes_after) (var Address adr)
            var Address adr2 := memory_allocate size null
            memory_copy adr adr2 size
            if lap=1
              text set adr2 size true
            else
              (var Str text8) set adr2 size true
              text := text8
            XFree adr
            status := success
            leave wait
          sleep 0.01
  c:sem release


graphic_console_record "x11" ConsoleX11