<commit_before>;;; -*- Mode: Lisp; Package: CLIM-CLX; -*-

;;;  (c) copyright 1998,1999,2000 by <NAME> (<EMAIL>)
;;;  (c) copyright 2000,2001 by 
;;;           <NAME> (<EMAIL>)
;;;           <NAME> (<EMAIL>)
;;;           <NAME> (<EMAIL>)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :clim-clx)

(declaim (inline round-coordinate))
(defun round-coordinate (x)
  "Function used for rounding coordinates."
  ;; We use "mercantile rounding", instead of the CL round to nearest
  ;; even number, when in doubt.
  ;;
  ;; Reason: As the CLIM drawing model is specified, you quite often
  ;; want to operate with coordinates, which are multiples of 1/2. 
  ;; Using CL:ROUND gives you "random" results. Using "mercantile
  ;; rounding" gives you consistent results.
  ;;
  ;; Note that CLIM defines pixel coordinates to be at the corners,
  ;; while in X11 they are at the centers. We don't do much about the
  ;; discrepancy, but rounding up at half pixel boundaries seems to
  ;; work well.
  (floor (+ x .5)))

;;; CLX-PORT class

(defclass clx-pointer (standard-pointer)
  ((cursor :accessor pointer-cursor :initform :upper-left)))

#|
 Perhaps this belongs elsewhere

 We have a couple of problems, one is character-sets.

 Unfortunately no-one seems to define what a character-set is, really.
 So, I define a character-set as being the same as a language, since
 a language is far more useful.

 This is important, since a given language may include many characters
 from what might be traditionally considered disparate character-sets.
 Also it is important, since we cannot simply map a character to a glyph
 in a language independent fashion, since the style of the character may
 have some language component.

 In our rendering/translation mechanism we switch fonts when a font fails
 to supply the glyph that we want. So, to facilitate this we need a given
 fontset with a set of disjoint ranges mapped to particular font/encoding
 pairs.

 For the time being, an alist should do here.

 We assume that we're given disjoint ranges for now, which is optimistic.
 Currently building a fontset will be a tricksy business, think about how
 to generalise this for the future.
|#

; this is to inform the text renderer which fontset it should be using.
; it is a complement to the graphics-context stuff, effectively.
; the #'translate uses/needs this to switch fonts

(defclass fontset () (
  ; of the form ((start . stop) font translator)
  (name
    :type     simple-string
    :initform "fontset"
    :initarg  :name
    :reader   fontset-name)
  (default-font
    :initform nil
    :reader fontset-default-font)
  (ranges
    :type     list
    :initform nil
    :initarg  :ranges)
  (ascent
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-ascent)
  (descent
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-descent)
  (height
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-height)
  (width
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-width)))

(defvar *fontset* nil)

(defmethod print-object ((object fontset) stream)
  (format stream "#<fontset ~A>" (fontset-name object)))

(defmacro make-fontset (name &body entries)
  (let ((fontset (gensym)))
    `(let ((,fontset (make-instance 'fontset :name ,name)))
       ,@(mapcar (lambda (entry)
                   (destructuring-bind (start finish font translator) entry
                     `(set-fontset-range ,fontset ,font ,translator ,start ,finish)))
                 entries)
       ,fontset)))

(defmethod set-fontset-range ((fontset fontset) font translator start finish)
  ; should check ordering invariants, disjointity, etc
  (with-slots (ranges ascent descent height default-font) fontset
    (unless default-font
      (setf default-font font))
    (push (list (cons start finish) font translator) ranges)
    (setf ascent  (max (xlib:font-ascent font) ascent))
    (setf descent (max (xlib:font-descent font) descent))
    (setf height  (+ ascent descent))))

(defun fontset-point-width (point &optional (fontset *fontset*))
  (let ((entry (fontset-point point fontset)))
    (if entry
        (destructuring-bind ((range-start . range-stop) font translator) entry
	  (declare (ignore range-start range-stop))
          (xlib:char-width font (funcall translator point)))
        0)))

(defun fontset-point (point &optional (fontset *fontset*))
  (%fontset-point fontset point))

(defmethod %fontset-point ((fontset fontset) point)

  (with-slots (ranges) fontset
    (assoc point ranges :test (lambda (point range)
                                (<= (car range) point (cdr range))))))

(defclass clx-port (clim-xcommon:keysym-port-mixin basic-port)
  ((display :initform nil
	    :accessor clx-port-display)
   (screen :initform nil
	   :accessor clx-port-screen)
   (window :initform nil
	   :accessor clx-port-window)
   (color-table :initform (make-hash-table :test #'eq))
   (cursor-table :initform (make-hash-table :test #'eq)
                 :accessor clx-port-cursor-table)
   (design-cache :initform (make-hash-table :test #'eq))
   (pointer :reader port-pointer)
   (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil)
   (selection-owner :initform nil :accessor selection-owner)
   (selection-timestamp :initform nil :accessor selection-timestamp)
   (font-families :accessor font-families)))

(defun automagic-clx-server-path ()  
  (let ((name (get-environment-variable "DISPLAY")))
    (assert name (name)
            "Environment variable DISPLAY is not set")
    (let* (; this code courtesy telent-clx.
           (slash-i (or (position #\/ name) -1))
           (colon-i (position #\: name :start (1+ slash-i)))
           (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
           (host (subseq name (1+ slash-i) colon-i))
           (dot-i (and colon-i (position #\. name :start colon-i)))
           (display (and colon-i
                      (parse-integer name
                                     :start (if decnet-colon-p
                                                (+ colon-i 2)
                                                (1+ colon-i))
                                     :end dot-i)))
           (screen (and dot-i
                     (parse-integer name :start (1+ dot-i))))
           (protocol
            (cond ((or (string= host "") (string-equal host "unix")) :local)
                  (decnet-colon-p :decnet)
                  ((> slash-i -1) (intern
                                   (string-upcase (subseq name 0 slash-i))
                                   :keyword))
                  (t :internet))))
      (list :clx
	    :host host
	    :display-id (or display 0)
	    :screen-id (or screen 0)
	    :protocol protocol))))

(defun helpfully-automagic-clx-server-path ()
  (restart-case (automagic-clx-server-path)
    (use-localhost ()
      :report "Use local unix display"
      (parse-clx-server-path '(:clx :host "" :protocol :unix)))))<commit_msg>Corrected host extraction from DISPLAY.<commit_after>;;; -*- Mode: Lisp; Package: CLIM-CLX; -*-

;;;  (c) copyright 1998,1999,2000 by <NAME> (<EMAIL>)
;;;  (c) copyright 2000,2001 by 
;;;           <NAME> (<EMAIL>)
;;;           <NAME> (<EMAIL>)
;;;           <NAME> (<EMAIL>)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :clim-clx)

(declaim (inline round-coordinate))
(defun round-coordinate (x)
  "Function used for rounding coordinates."
  ;; We use "mercantile rounding", instead of the CL round to nearest
  ;; even number, when in doubt.
  ;;
  ;; Reason: As the CLIM drawing model is specified, you quite often
  ;; want to operate with coordinates, which are multiples of 1/2. 
  ;; Using CL:ROUND gives you "random" results. Using "mercantile
  ;; rounding" gives you consistent results.
  ;;
  ;; Note that CLIM defines pixel coordinates to be at the corners,
  ;; while in X11 they are at the centers. We don't do much about the
  ;; discrepancy, but rounding up at half pixel boundaries seems to
  ;; work well.
  (floor (+ x .5)))

;;; CLX-PORT class

(defclass clx-pointer (standard-pointer)
  ((cursor :accessor pointer-cursor :initform :upper-left)))

#|
 Perhaps this belongs elsewhere

 We have a couple of problems, one is character-sets.

 Unfortunately no-one seems to define what a character-set is, really.
 So, I define a character-set as being the same as a language, since
 a language is far more useful.

 This is important, since a given language may include many characters
 from what might be traditionally considered disparate character-sets.
 Also it is important, since we cannot simply map a character to a glyph
 in a language independent fashion, since the style of the character may
 have some language component.

 In our rendering/translation mechanism we switch fonts when a font fails
 to supply the glyph that we want. So, to facilitate this we need a given
 fontset with a set of disjoint ranges mapped to particular font/encoding
 pairs.

 For the time being, an alist should do here.

 We assume that we're given disjoint ranges for now, which is optimistic.
 Currently building a fontset will be a tricksy business, think about how
 to generalise this for the future.
|#

; this is to inform the text renderer which fontset it should be using.
; it is a complement to the graphics-context stuff, effectively.
; the #'translate uses/needs this to switch fonts

(defclass fontset () (
  ; of the form ((start . stop) font translator)
  (name
    :type     simple-string
    :initform "fontset"
    :initarg  :name
    :reader   fontset-name)
  (default-font
    :initform nil
    :reader fontset-default-font)
  (ranges
    :type     list
    :initform nil
    :initarg  :ranges)
  (ascent
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-ascent)
  (descent
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-descent)
  (height
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-height)
  (width
    :type     integer
    :initform 0
    :initarg  :ascent
    :reader   fontset-width)))

(defvar *fontset* nil)

(defmethod print-object ((object fontset) stream)
  (format stream "#<fontset ~A>" (fontset-name object)))

(defmacro make-fontset (name &body entries)
  (let ((fontset (gensym)))
    `(let ((,fontset (make-instance 'fontset :name ,name)))
       ,@(mapcar (lambda (entry)
                   (destructuring-bind (start finish font translator) entry
                     `(set-fontset-range ,fontset ,font ,translator ,start ,finish)))
                 entries)
       ,fontset)))

(defmethod set-fontset-range ((fontset fontset) font translator start finish)
  ; should check ordering invariants, disjointity, etc
  (with-slots (ranges ascent descent height default-font) fontset
    (unless default-font
      (setf default-font font))
    (push (list (cons start finish) font translator) ranges)
    (setf ascent  (max (xlib:font-ascent font) ascent))
    (setf descent (max (xlib:font-descent font) descent))
    (setf height  (+ ascent descent))))

(defun fontset-point-width (point &optional (fontset *fontset*))
  (let ((entry (fontset-point point fontset)))
    (if entry
        (destructuring-bind ((range-start . range-stop) font translator) entry
	  (declare (ignore range-start range-stop))
          (xlib:char-width font (funcall translator point)))
        0)))

(defun fontset-point (point &optional (fontset *fontset*))
  (%fontset-point fontset point))

(defmethod %fontset-point ((fontset fontset) point)

  (with-slots (ranges) fontset
    (assoc point ranges :test (lambda (point range)
                                (<= (car range) point (cdr range))))))

(defclass clx-port (clim-xcommon:keysym-port-mixin basic-port)
  ((display :initform nil
	    :accessor clx-port-display)
   (screen :initform nil
	   :accessor clx-port-screen)
   (window :initform nil
	   :accessor clx-port-window)
   (color-table :initform (make-hash-table :test #'eq))
   (cursor-table :initform (make-hash-table :test #'eq)
                 :accessor clx-port-cursor-table)
   (design-cache :initform (make-hash-table :test #'eq))
   (pointer :reader port-pointer)
   (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil)
   (selection-owner :initform nil :accessor selection-owner)
   (selection-timestamp :initform nil :accessor selection-timestamp)
   (font-families :accessor font-families)))

(defun automagic-clx-server-path ()  
  (let ((name (get-environment-variable "DISPLAY")))
    (assert name (name)
            "Environment variable DISPLAY is not set")
    (let* (; this code courtesy telent-clx.
           (slash-i (or (position #\/ name) -1))
           (colon-i (position #\: name :start (1+ slash-i)))
           (decnet-colon-p (and colon-i (eql (elt name (1+ colon-i)) #\:)))
           (host (subseq name (1+ slash-i) (or colon-i (length name))))
           (dot-i (and colon-i (position #\. name :start colon-i)))
           (display (and colon-i
                      (parse-integer name
                                     :start (if decnet-colon-p
                                                (+ colon-i 2)
                                                (1+ colon-i))
                                     :end dot-i)))
           (screen (and dot-i
                     (parse-integer name :start (1+ dot-i))))
           (protocol
            (cond ((or (string= host "") (string-equal host "unix")) :local)
                  (decnet-colon-p :decnet)
                  ((> slash-i -1) (intern
                                   (string-upcase (subseq name 0 slash-i))
                                   :keyword))
                  (t :internet))))
      (list :clx
	    :host host
	    :display-id (or display 0)
	    :screen-id (or screen 0)
	    :protocol protocol))))

(defun helpfully-automagic-clx-server-path ()
  (restart-case (automagic-clx-server-path)
    (use-localhost ()
      :report "Use local unix display"
      (parse-clx-server-path '(:clx :host "" :protocol :unix)))))
{'fraction_non_alphanumeric': 0.11049013939744332, 'fraction_numerical': 0.007194706751461425, 'mean_word_length': 2.6803782505910165, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 22, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1033915', 'n_tokens_mistral': 4771, 'n_tokens_neox': 4502, 'n_words': 1702}