🚀 go-pugleaf

$B3'MM(J

$B:#0f!!9nD*(J(imai@bpe.osaka-u.ac.jp)$B$5$s$+$i5v2D$rF@$^$7$?$N$G!"(J
MCL 2.0b1$B$N%(%G%#%?(JFred$B$rF|K\8lBP1~$K$9$k%W%m%0%i%`$rEj9F$7$^$9!#(J

$BKM$b;n$7$F$_$^$7$?$,!"$J$+$J$+N)GI$J(JEmacs editor$B$H$7$FF0:n$7$^$9!#(J
$BK\BN$,$A$g$C$H=E$9$.$k(J(3MB$B%a%b%j$r?)$&(J)$B$N$,FqE@$G$9$,!#(J

$B$J$*!"(J

1) $B:#0f$5$s$O%K%e!<%9$rFI$s$G$*$i$l$J$$$N$G!"%3%a%s%H$,$"$l$P!"(J
$B%a!<%k$G$*4j$$$7$^$9!#(J

2) $B$d$C$D$1;E;v$G:n$C$?$b$N$G!"%3!<%I$b1x$J$$$7!"$^$@IT==J,$JE@(J
$B$b$"$j$^$9!#$I$J$?$+2~A1$5$l$?$H$3$m$,$"$l$P!"$=$l$r65$($F$/$@$5(J
$B$$!#(J

3) 2.0b1 $B0J9_$G$OJQ99$7$J$$$HF0$+$J$$ItJ,$,$"$k!#(J

$B$H$N$3$H$G$7$?!#$<$R$h$m$7$/$*4j$$$7$^$9!#(J

$B:#0f$5$s!"$"$j$,$H$&$4$6$$$^$7$?!#(J

                $BLnEg5WM:(J

$B0J2<$O:#0f$5$s$+$i$NCm0U$G$9!#(J

Date: Mon, 18 May 92 11:12:55 JST
From: Katsunobu Imai <imai@sakura.bpe.osaka-u.ac.jp>

load $B$7$?8e!$(J option-key $B$r2!$7$J$,$i!$(J New $B$d(J Open menu $B$rA*$V(J
$B$H!$F|K\8l$,;H$($k$h$&$K$J$C$F$$$^$9!%$=$l$+$i!$(J load $B$9$kA0$K(J
Example folder $B$NCf$N!$(J assorted-fred-commands.lisp $B$r(J load $B$7$F(J
$B$*$$$F$/$@$5$$!%(J

$B8=>u$G$N:GBg$NLdBj$O!$4A;zJQ498e!$3NDj$7$F(J fred $B$KN.$79~$^$l$F$$(J
$B$k:GCf$K(J GC $B$,5/$-$k$H!$J8;z$,Mn$A$k$3$H$G$9!%$=$s$J$KIQHK$K5/$-(J
$B$k$o$1$G$O$J$$$N$G!$D|$a$F$$$^$9!%$^$?!$$H$-$I$-J8;z$,2=$1$^$9!%(J
$B$3$l$O$o$?$7$N@UG$$G$9!%$=$l$+$i!$:#$^$G$o$?$7$KI,MW$,$J$+$C$?$?(J
$B$a$K!$(J fred-window $B$N$_$rBP>]$K$7$F$*$j!$(J fred-dialog-item $B$K$O(J
$B2?$b$7$F$$$^$;$s!%K\Ev$O!$(J fred-mixin-j $B$r:n$k$+!$(J fred-mixin $B$K(J
$B:Y9)$r$9$Y$-$G$7$g$&!%(J fred-window-j $B$KBP$7$FDj5A$5$l$F$$$k(J
method $B$r(J fred-mixin $B$KBP$9$kDj5A$KJQ$($k$HB?J,F0:n$9$k$H;W$$$^(J
$B$9!%(J

$B8D?ME*$K$O!$D9$/$J$C$F2~9T$;$:$KJ#?t9T$K$o$?$C$?$H$-$K!$>e2<(J
$B$N%+!<%=%k0\F0$,=>Mh$N(J editor $B$N$h$&$K$J$i$:<!$NCJMn$K0\$C$F(J
$B$7$^$&$N$r2?$H$+$9$k$3$H$H!$(J double-click $B$G4A;z$d%+%J$NItJ,(J
$B$@$1$rA*$V$H8@$C$?$h$&$J$3$H$r=q$3$&$H;W$C$F$$$k$N$G$9$,!$$=(J
$B$&$$$&$b$N$r=q$$$F$/$l$k?M$,$$$k$HK\Ev$K$"$j$,$?$$$G$9!%(J

$B!{(JMCL 2.0b $B$N(Jpathname $B$K$D$$$F(J
Maicntosh $B$N(J escape-character $B$O(J #\266 (control-q option-d)
$B$G$9$,!$(Jescape-char $B$rFs$DJB$Y$F$b!$(J escap-char $B<+BN$r(J 
escape $B$7$F$O$/$l$^$;$s!%$=$N$?$a!$0lIt$N4A;z$,%U%!%$%kL>$K(J
$B;H$($^$;$s!%!J$3$l$O(J MCL $B$N(J bug $B$G$7$g$&$,!$(J escape-char $B$r(J 
file $BL>$K;H$$$?$$$H;W$&%"%a%j%+?M$O$$$J$$$G$7$g$&$+$i!$;EJ}(J
$B$N$J$$$H$3$m$G$9!%!K(J

-----------


#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
#	fred-j.lisp
# This archive created: Mon May 18 21:37:04 1992
export PATH; PATH=/bin:/usr/bin:$PATH
if test -f 'fred-j.lisp'
then
	echo shar: "will not over-write existing file 'fred-j.lisp'"
else
cat << \SHAR_EOF > 'fred-j.lisp'
;;;;
;;;; fred-window-j.lisp
;;;;
;;   $B$H$j$"$($:!$(J option-key $B$r2!$7$J$,$i!$(JNew, Open $B$rA*$V$H!$(Jfred-j $B$K$J$k$h$&$K$J$C$F$$$^$9!%(J
;;   imai@bpe.osaka-u.ac.jp
;;
;; 92.05.15 ki   current version works only on 2.0b, needs some changes on 2.0f
;; 92.05.15 ki   menu-item-actions changed, but these are temporary modifications
;; 92.04.05 ki   buffer-forward-char-kanji-code-p last pos error fixed
;; 92.04.04 ki   ED-RUBOUT-CHAR :before ((window fred-window-j)) changed, supports multiple-select delete
;; 92.04.04 ki   view-click-event-handler for fred-window-j :before -> :after
;; 92.01.25 ki   wrap-p t in edj
;; 92.01.25 ki   wrap-p t in edjf
;; 91.08.31 ki   cursor insertion works correctly
;; 91.07.25 ki   using change-class in edj,edjf...
;; 91.07.02 ki   KeyScript for KanjiTalk 7.0patch 0.1
;; 91.06.30 ki   add kanji-char-buffer
;; 91.05.18 ki   MCL2.0b1p2


(defclass fred-window-j (fred-window)
  ((kanji-char-buffer :initform nil :accessor kanji-char-buffer)))


(defmethod view-key-event-handler :around ((window fred-window-j) c)
  ;(when (option-key-p) (call-next-method))
  (if (and (<= #x81 (char-int c) #xEA) (null (kanji-char-buffer window)))         ; (logbitp 7 (char-int c))
    (setf (kanji-char-buffer window) c)
    (if (kanji-char-buffer window)
      (progn
        (write-string (format nil "~A~A" (kanji-char-buffer window) c) window)
        (setf (kanji-char-buffer window) nil))
      (call-next-method)))
  (fred-update window)
  )

(defun buffer-left-insertion-code (buffer-mark)
  (let ((pos (buffer-position buffer-mark)))
    (if (plusp pos)
      (char-int (buffer-char buffer-mark (1- pos)))
      0)))          ;;; caution !!!  0 at start pos


(defun buffer-char-kanji-code-p (buffer-mark)
  (unless (< (buffer-position buffer-mark) 2)
    (let ((first-code (char-int (buffer-char
                                 buffer-mark
                                 (- (buffer-position buffer-mark) 2))))
          (second-code (char-int (buffer-char
                                 buffer-mark
                                 (- (buffer-position buffer-mark) 1)))))
      
      (cond ((null (<= #x81 first-code #xEA)) nil)
            ((= (- (buffer-position buffer-mark)
                   (find-most-recent-ascii-pos buffer-mark)) 1) nil)
            (t t)))))


(defun buffer-forward-char-kanji-code-p (buffer-mark)
  (let ((pos (buffer-position buffer-mark))
        (size (buffer-size buffer-mark))
        first-code)
    (unless (= pos size)
      (setf first-code (char-int (buffer-char
                                  buffer-mark
                                  (+ pos 0))))
      
      (<= #x81 first-code #xEA))))


(defun find-ascii-char-forward (buffer-mark start &aux (ascii-pos start))
  (loop
    (cond ((= (buffer-position buffer-mark) start)
           (return ascii-pos))
          ((<= #x81 (char-int (buffer-char buffer-mark start)) #xEA)
           (incf start))
          ((null (<= #x81 (char-int (buffer-char buffer-mark start)) #xEA))
           (setf ascii-pos start)))
    (incf start)))


(defun find-most-recent-ascii-pos (buffer-mark)
  (let ((bp (buffer-char-pos buffer-mark
                             #\newline
                             :end (buffer-position buffer-mark)
                             :from-end t)))
    (unless bp (setf bp 0))
    (find-ascii-char-forward buffer-mark bp)))


(defun line-head (buffer-mark)
  (let ((bp (buffer-char-pos buffer-mark
                             #\newline
                             :start 0
                             :end (buffer-position buffer-mark)
                             :from-end t)))
    (if bp
      (1+ bp)
      0)))


(defun buffer-force-regal-insertion-point (buffer-mark   
                                           &aux 
                                           (insert-pos (buffer-position buffer-mark))
                                           (pos (line-head buffer-mark)))
  (unless (= (buffer-line-end buffer-mark) insert-pos)
    (loop
      (cond ((>= pos insert-pos) (return))
            ((<= #x81 (char-int (buffer-char buffer-mark pos)) #xEA)
             (incf pos))
            ;((null (<= #x81 (char-int (buffer-char buffer-mark pos)) #xEA))
            ; (setf pp pos))
            )
      (incf pos))
    (set-mark buffer-mark pos)
    ))

(defun rubout-fred-j (window)
  (let* ((buffer-mark (fred-buffer window))
         (pos (buffer-position buffer-mark)))
    (if (buffer-char-kanji-code-p buffer-mark)
      (buffer-delete buffer-mark (- pos 2) pos)
      (buffer-delete buffer-mark (1- pos) pos)))
  )

(defmethod ED-BACKWARD-CHAR :before ((window fred-window-j))
  (let* ((mark (fred-buffer window))
         (pos (buffer-position mark)))
    (if (buffer-char-kanji-code-p mark)
      (if (>= (- pos 1) 0)        
        (set-mark mark (- pos 1))))))

(defmethod ED-RUBOUT-CHAR :before ((window fred-window-j))
  (let* ((buffer-mark (fred-buffer window))
         (pos (buffer-position buffer-mark))
         value1 value2)
    (multiple-value-setq (value1 value2) (selection-range window))
    (if (= value1 value2)
      (if (buffer-char-kanji-code-p buffer-mark)
        (buffer-delete buffer-mark (1- pos) pos))
      (fred-force-regal-selection-range window))
  ))

(defmethod ED-FORWARD-CHAR :before ((window fred-window-j))
  (let* ((mark (fred-buffer window))
         (pos (buffer-position mark))
         (size (buffer-size mark)))
    (when (buffer-forward-char-kanji-code-p mark)
      (when (<= (+ 1 pos) size)
        (set-mark mark (+ pos 1))))))

(defmethod ED-PREVIOUS-LINE :after ((window fred-window-j))
  (buffer-force-regal-insertion-point (fred-buffer window)))

(defmethod ED-NEXT-LINE :after ((window fred-window-j))
  (buffer-force-regal-insertion-point (fred-buffer window)))

(defmethod view-click-event-handler :after ((window fred-window-j) where)
  (declare (ignore where))
  (buffer-force-regal-insertion-point (fred-buffer window))
  )


(defmethod window-mouse-up-event-handler :after ((window fred-window-j))
  (fred-force-regal-selection-range window)
)

; $BK\Mh!$(Jwindow-mouse-up-event-handler$B$G!$(Jselct$B$9$k$H$-$N(Jmouse-up$B$,;_$a$i$l$l$P!$$3$3$K(J
; $B=q$$$?$h$&$J(Jcut, copy, delet$B$J$I$X$N(Jpatch$B$"$F$O;H$o$J$/$F$9$`$N$@$,!$2?8N$+;_$a$k$3$H$,=PMh$J$$$N$G!%(J

(defmethod cut :before ((window fred-window-j))
  (fred-force-regal-selection-range window))

(defmethod copy :before ((window fred-window-j))
  (fred-force-regal-selection-range window))

;;; has bugs !!!!??
(defun fred-force-regal-selection-range
       (fred-window &aux start-pos (pos (buffer-position (fred-buffer fred-window))))
  (multiple-value-bind (selection-1 selection-2)
                       (selection-range fred-window)
    
    (if (=  pos selection-1)
      (setf start-pos selection-2)
      (setf start-pos selection-1))
    (let ((mark (make-mark (fred-buffer fred-window) start-pos)))
      (buffer-force-regal-insertion-point mark)
      (set-selection-range fred-window (buffer-position mark)))))



(defun edj (&optional (wrap-p t))
  (make-instance 'fred-window-j :view-font '("ASLFont+" 9 :srcor :plain)
                 :wrap-p wrap-p))


(defun edjf (&optional (wrap-p t))
  (let* ((pathname (choose-file-dialog))
         (w (ed pathname)))
    (when wrap-p
      (ccl::ed-toggle-wrap-p w))
    (change-class w 'fred-window-j)))


(defun edit-j-text (pathname &optional (wrap-p nil))
  (let ((w (ed pathname)))
    (when wrap-p
      (ccl::ed-toggle-wrap-p w))
    (change-class w 'fred-window-j)))

;;;
;;;

(defvar *first-char-tyo* nil)

(defmethod stream-tyo :around ((window fred-window-j) c)
  (when (option-key-p) (call-next-method))
  (if (and (<= #x81 (char-int c) #xEA) (null *first-char-tyo*))         ; (logbitp 7 (char-int c))
    (setf *first-char-tyo* c)
    (if *first-char-tyo*
      (progn
        (write-string (format nil "~A~A" *first-char-tyo* c) window)
        (setf *first-char-tyo* nil))
      (call-next-method)))
  (fred-update window)
  )



(defun kanji-talk-installed-p ()
  (not (zerop (#_GetScript #$smJapanese #$smVersion))))


;;;
;;;
;;;

(let* ((new-menu-item (find-menu-item *file-menu* "New"))
       (new-menu-item-function (menu-item-action-function new-menu-item))
       (open-menu-item (find-menu-item *file-menu* "Open))
       (open-menu-item-function (menu-item-action-function open-menu-item)))
  (set-menu-item-action-function new-menu-item
                                 #'(lambda ()
                                     (if (option-key-p)
                                       (edj)
                                       (funcall new-menu-item-function))))
  (set-menu-item-action-function open-menu-item
                                 #'(lambda ()
                                     (if (option-key-p)
                                       (edjf)
                                       (funcall open-menu-item-function)))))



SHAR_EOF
fi
exit 0
#	End of shell archive