summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribilo/utils/justify.scm102
1 files changed, 55 insertions, 47 deletions
diff --git a/src/guile/skribilo/utils/justify.scm b/src/guile/skribilo/utils/justify.scm
index 8e069af..3ed38f7 100644
--- a/src/guile/skribilo/utils/justify.scm
+++ b/src/guile/skribilo/utils/justify.scm
@@ -1,40 +1,46 @@
-;=============== ~/prgm/project/scribe/scribetext/justify.scm ================
+;;; justify.scm -- Producing justified text.
+;;;
+;;; Copyright 2008 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2001 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
-;-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----
-;*=====================================================================*/
-;* serrano/prgm/project/scribe/scribetext/justify.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Thu Nov 1 09:21:20 2001 */
-;* Last change : Sun Dec 9 14:59:11 2001 (serrano) */
-;* Copyright : 2001 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The justifiers */
-;*=====================================================================*/
+(define-module (skribilo utils justify)
+ :export (make-justifier output-flush
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module __scribetext_justify
-
- (export (make-justifier::procedure ::int ::symbol)
- (output-flush ::int)
-
*text-column-width*
*text-justification*
*margin*
-
- (output ::bstring)
- (output-token ::bstring)
- (output-center ::bstring)
- (output-newline)
- (justification-width::int)
- (with-justification ::procedure ::procedure . margin)
- (with-justification/noflush ::procedure ::procedure . margin))
-
- (eval (export *text-column-width*)
- (export *text-justification*)))
+ output output-token output-center
+ output-newline justification-width
+ with-justification with-justification/noflush))
+
+;;; Author: Manuel Serrano, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Provide a set of tools that makes it easy to produce justified text,
+;;; i.e., text that automatically wraps after, say, 80 columns, indented
+;;; text, etc.
+;;;
+;;; Code:
+
+
;*---------------------------------------------------------------------*/
;* *text-column-width* ... */
;*---------------------------------------------------------------------*/
@@ -48,13 +54,13 @@
(let ((len (string-length str)))
(let loop ((r 0))
(cond
- ((=fx r len)
+ ((= r len)
str)
((char=? (string-ref str r) #a008)
(string-set! str r #\Space)
- (loop (+fx r 1)))
+ (loop (+ r 1)))
(else
- (loop (+fx r 1)))))))
+ (loop (+ r 1)))))))
;*---------------------------------------------------------------------*/
;* string-replace ... */
@@ -63,13 +69,13 @@
(let* ((len (string-length str1))
(str2 (make-string len)))
(let loop ((r 0))
- (if (=fx r len)
+ (if (= r len)
str2
(let ((c (string-ref str1 r)))
(if (char=? c c1)
(string-set! str2 r c2)
(string-set! str2 r c))
- (loop (+fx r 1)))))))
+ (loop (+ r 1)))))))
;*---------------------------------------------------------------------*/
;* output-center ... */
@@ -124,7 +130,7 @@
;* output-flush ... */
;*---------------------------------------------------------------------*/
(define (output-flush margin)
- (for-each (if (>fx margin 0)
+ (for-each (if (> margin 0)
(let ((m (make-string margin #\space)))
(lambda (x) (print m (text-string x))))
(lambda (x) (print (text-string x))))
@@ -142,7 +148,7 @@
(define (with-justification justifier thunk . margin)
(output-flush *margin*)
(let ((old-margin *margin*))
- (if (pair? margin) (set! *margin* (+fx *margin* (car margin))))
+ (if (pair? margin) (set! *margin* (+ *margin* (car margin))))
(set! *justifiers* (cons justifier *justifiers*))
(thunk)
(output-flush *margin*)
@@ -154,7 +160,7 @@
;*---------------------------------------------------------------------*/
(define (with-justification/noflush justifier thunk . margin)
(let ((old-margin *margin*))
- (if (pair? margin) (set! *margin* (+fx *margin* (car margin))))
+ (if (pair? margin) (set! *margin* (+ *margin* (car margin))))
(set! *justifiers* (cons justifier *justifiers*))
(thunk)
(let ((res ((car *justifiers*) 'flush)))
@@ -176,7 +182,7 @@
;*---------------------------------------------------------------------*/
;* kotrts ... */
;*---------------------------------------------------------------------*/
-(define (kotrts str::bstring delims::pair)
+(define (kotrts str delims)
(let ((stop (string-length str)))
(let loop ((cur 0)
(mark #f)
@@ -201,7 +207,7 @@
;*---------------------------------------------------------------------*/
;* string-insert! ... */
;*---------------------------------------------------------------------*/
-(define (string-insert! str-to::bstring str-from::bstring offset::int)
+(define (string-insert! str-to str-from offset)
(let ((len1 (string-length str-to))
(len2 (string-length str-from)))
(if (> (+ len2 offset) len1)
@@ -218,7 +224,7 @@
;*---------------------------------------------------------------------*/
;* make-justified-line ... */
;*---------------------------------------------------------------------*/
-(define (make-justified-line tokens::pair-nil width::int)
+(define (make-justified-line tokens width)
(let ((result (make-string width #\space)))
(cond
((null? tokens)
@@ -259,7 +265,7 @@
;*---------------------------------------------------------------------*/
;* make-formated-line ... */
;*---------------------------------------------------------------------*/
-(define (make-formated-line tokens::pair-nil width::int cursor::int)
+(define (make-formated-line tokens width cursor)
(let ((result (make-string width #\space)))
(if (null? tokens)
result
@@ -278,7 +284,7 @@
;*---------------------------------------------------------------------*/
;* make-centered-line ... */
;*---------------------------------------------------------------------*/
-(define (make-centered-line tokens::pair-nil width::int)
+(define (make-centered-line tokens width)
(make-formated-line tokens
width
(quotient (- width
@@ -289,13 +295,13 @@
;*---------------------------------------------------------------------*/
;* make-flushleft-line ... */
;*---------------------------------------------------------------------*/
-(define (make-flushleft-line tokens::pair-nil width::int)
+(define (make-flushleft-line tokens width)
(make-formated-line tokens width 0))
;*---------------------------------------------------------------------*/
;* make-flushright-line ... */
;*---------------------------------------------------------------------*/
-(define (make-flushright-line tokens::pair-nil width::int)
+(define (make-flushright-line tokens width)
(make-formated-line tokens
width
(- width
@@ -305,7 +311,7 @@
;*---------------------------------------------------------------------*/
;* tokens-justify ... */
;*---------------------------------------------------------------------*/
-(define (tokens-justify justifier::procedure tokens::pair-nil width::int)
+(define (tokens-justify justifier tokens width)
(define (reverse-line lines)
(let ((nl (string #\Newline)))
(let loop ((ls lines)
@@ -423,3 +429,5 @@
(fprint (current-error-port) "s: " s)
(apply string-append s))
+
+;;; justify.scm ends here
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 21:19:32 +0000