/[mcclim]/mcclim/recording.lisp
ViewVC logotype

Diff of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.81 by gilbert, Sat Jun 7 21:57:12 2003 UTC revision 1.82 by gilbert, Sun Jun 8 00:34:47 2003 UTC
# Line 7  Line 7 
7  ;;;           Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)  ;;;           Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8  ;;;           Lionel Salabartan (salabart@emi.u-bordeaux.fr)  ;;;           Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9  ;;;  (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru)  ;;;  (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru)
10    ;;;  (c) copyright 2003 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
11    
12  ;;; This library is free software; you can redistribute it and/or  ;;; This library is free software; you can redistribute it and/or
13  ;;; modify it under the terms of the GNU Library General Public  ;;; modify it under the terms of the GNU Library General Public
# Line 1730  were added." Line 1731  were added."
1731              (when errorp              (when errorp
1732                (error "~S is not contained in ~S." record stream)))))))                (error "~S is not contained in ~S." record stream)))))))
1733    
 (defun copy-textual-output-history (window stream &optional region record)  
   ;; FIXME  
   (declare (ignore window stream region record))  
   (error "Not implemented."))  
   
1734  ;;; 16.4.3. Text Output Recording  ;;; 16.4.3. Text Output Recording
1735  (defmethod stream-text-output-record  (defmethod stream-text-output-record
1736      ((stream standard-output-recording-stream) text-style)      ((stream standard-output-recording-stream) text-style)
# Line 1968  according to the flags RECORD and DRAW." Line 1964  according to the flags RECORD and DRAW."
1964                                            (handle-repaint s region))                                            (handle-repaint s region))
1965                                        sheet                                        sheet
1966                                        region))                                        region))
1967    
1968    ;;; ----------------------------------------------------------------------------
1969    ;;;  Baseline
1970    ;;;
1971    
1972    (defmethod output-record-baseline ((record output-record))
1973      "Fall back method"
1974      (values
1975       (bounding-rectangle-max-y record)
1976       nil))
1977    
1978    (defmethod output-record-baseline ((record standard-text-displayed-output-record))
1979      (with-slots (baseline) record
1980        (values
1981         baseline
1982         t)))
1983    
1984    (defmethod output-record-baseline ((record compound-output-record))
1985      (map-over-output-records (lambda (sub-record)
1986                                 (multiple-value-bind (baseline definitive)
1987                                     (output-record-baseline sub-record)
1988                                   (when definitive
1989                                     (return-from output-record-baseline
1990                                       (values baseline t)))))
1991                               record)
1992      (values (bounding-rectangle-max-y record) nil))
1993    
1994    ;;; ----------------------------------------------------------------------------
1995    ;;;  copy-textual-output
1996    ;;;
1997    
1998    (defun copy-textual-output-history (window stream &optional region record)
1999      (unless region (setf region +everywhere+))
2000      (unless record (setf record (stream-output-history window)))
2001      (let* ((text-style (medium-default-text-style window))
2002             (char-width (stream-character-width window #\n :text-style text-style))
2003             (line-height (+ (stream-line-height window :text-style text-style)
2004                             (stream-vertical-spacing window))))
2005        #+NIL
2006        (print (list char-width line-height
2007                     (stream-line-height window :text-style text-style)
2008                     (stream-vertical-spacing window))
2009               *trace-output*)
2010        ;; humble first ...
2011        (let ((cy nil)
2012              (cx 0))
2013          (labels ((grok-record (record)
2014                     (cond ((typep record 'standard-text-displayed-output-record)
2015                            (with-slots (start-y start-x end-x strings) record
2016                              (setf cy (or cy start-y))
2017                              #+NIL
2018                              (print (list (list cx cy)
2019                                           (list start-x end-x start-y))
2020                                     *trace-output*)
2021                              (when (> start-y cy)
2022                                (dotimes (k (round (- start-y cy) line-height))
2023                                  (terpri stream))
2024                                (setf cy start-y
2025                                      cx 0))
2026                              (dotimes (k (round (- start-x cx) char-width))
2027                                (princ " " stream))
2028                              (setf cx end-x)
2029                              (dolist (string strings)
2030                                (with-slots (string) string
2031                                  (princ string stream))
2032                                #+NIL
2033                                (print (list start-x start-y string)
2034                                       *trace-output*))))
2035                           (t
2036                            (map-over-output-records-overlapping-region #'grok-record
2037                                                                        record region)))))
2038            (grok-record record)))))

Legend:
Removed from v.1.81  
changed lines
  Added in v.1.82

  ViewVC Help
Powered by ViewVC 1.1.5