Gantt charts in Functional PostScript

Here's a script for making PostScript illustrations of Gantt charts for
process schedules that I wrote to help typeset my Operating Systems homework.

Run gantt.scm process-id process-cpu-burst-time ... listing ids and burst time
pairs in the order the processes are to be executed to get a chart.

Eg. gantt.scm 2 1 5 5 1 10 3 2 4 1 produces gantt.ps (attached) that contains
an illustration like this:
  ____ ____________ ______________________ ______ ____
 |    |            |                      |      |    |
 | P2 |     P5     |          P1          |  P3  | P4 |
 |____|____________|______________________|______|____|
 0    1            6                      16     18   19

-d


#! /usr/bin/sh
IFS=" "
exec scsh -lm fps-package.scm -o fps -e main -s "$0" "$@"
!#
#|
   Copyright (c) 2003 David Van Horn
   Licensed under the Academic Free License version 2.0

   Process Gantt charts rendered in PostScript
   [email protected]

   This script creates Gantt charts for process schedules rendered in
   PostScript using Functional PostScript in the style of "Operating System
   Concepts" (5 ed.) by Silberschatz and Galvin.

   This script depends on a patch for FPS 1.0 to make it work with scsh 0.5.3
   and later and also a patch I've written to add a few primitives.  See links
   below.

   scsh -- The Scheme Shell
   <http://www.scsh.net/>

   Functional PostScript
   <ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/fps.html>

   FPS 1.0 Patch for scsh 0.5.3 and later
   <ftp://ftp.scsh.net/pub/scsh/contrib/fps/fps-1.0-patch-for-scsh-0.5.3>

   My patch to add CENTER and TRANSLATE-ABSOLUTE primitives
   <http://www.cs.uvm.edu/~dvanhorn/scheme/fps-1.0-patch-primitives>
|#

(define large-font (font "Times-Italic" 18))
(define small-font (font "Times-Roman" 12))

(define *unit-length* 24)

(define (make-gantt process-ids process-lengths)
  (apply compose
         (cons (make-time-mark "0" 0)
               (map (let ((start 0))
                      (lambda (p length)
                        (let ((segment (make-segment p start length)))
                          (set! start (+ start length))
                          segment)))
                    process-ids
                    process-lengths))))

(define (make-segment i start length)
  (translate
   (* start *unit-length*) 0
   (compose
    (center
     (rect (pt 0 12) (* length *unit-length*) 50)
     (join
      (simple-string->glyphpath large-font "P")
      (simple-string->glyphpath small-font i)))
    (make-time-mark (number->string (+ start length)) length))))

(define (make-time-mark str offset)
  (let ((str-glyph (simple-string->glyphpath small-font str)))
    (translate
     (- (* offset *unit-length*)
        (/ (- (pt:x (bounding-box:max (bounding-box str-glyph)))
              (pt:x (bounding-box:min (bounding-box str-glyph))))
           2))
     0
     str-glyph)))

(define (usage) (display "gantt.scm id length ...\n"))

(define (main args)
  (if (null? (cdr args)) (begin (usage) (exit)))
  (show-w/ps2-text-channel
   "gantt.ps"
   (stroke
    (translate
     50 700
     (call-with-values
         (lambda ()
           (unzip2
            (let loop ((args (cdr args)) (accum '()))
              (cond
               ((null? args) (reverse! accum))
               ((< (length args) 2) (usage) (exit))
               (else
                (loop (cddr args)
                      (cons (list (car args) (string->number (cadr args)))
                            accum)))))))
       make-gantt)))))

_______________________________________________
Lambda mailing list
[email protected]
http://ballistichelmet.org/mailman/listinfo/lambda