Commit 21975630 authored by gerd's avatar gerd

Initial revision.


git-svn-id: https://godirepo.camlcity.org/svn/app-presentation/trunk@1 50e5f3cf-a9f2-0310-83d8-d11ec64cb5ab
parents
# make readme: make bytecode executable
# make readme.opt: make native executable
# make clean: remove intermediate files
# make CLEAN: remove intermediate files (recursively)
# make distclean: remove any superflous files
# make install
#----------------------------------------------------------------------
LIB = /usr/local/lib/presentation
BIN = /usr/local/bin
.PHONY: presentation.bin
presentation.bin:
$(MAKE) -f Makefile.code presentation.bin
.PHONY: presentation.bin.opt
presentation.bin.opt:
$(MAKE) -f Makefile.code presentation.bin.opt
#.PHONY: readme.opt
#readme.opt:
# $(MAKE) -f Makefile.code readme.opt
.PHONY: clean
clean:
rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa
.PHONY: CLEAN
CLEAN: clean
.PHONY: distclean
distclean: clean
rm -f *~ depend depend.pkg
rm -f presentation.bin
.PHONY: install
install:
mkdir -p $(LIB)
cp presentation presentation.bin make-headline make-headline.scm $(LIB)
echo "#! /bin/sh" >$(BIN)/presentation
echo 'exec $(LIB)/presentation "$$@"' >>$(BIN)/presentation
chmod 775 $(BIN)/presentation
#----------------------------------------------------------------------
# specific rules for this package:
OBJECTS = to_html.cmo
XOBJECTS = $(OBJECTS:.cmo=.cmx)
ARCHIVE = presentation.cma
XARCHIVE = presentation.cmxa
NAME = presentation
REQUIRES = unix pcre pxp
presentation.bin: $(ARCHIVE) main.cmo
ocamlfind ocamlc -o presentation.bin -g -custom -package "$(REQUIRES)" \
-linkpkg $(ARCHIVE) main.cmo
presentation.bin.opt: $(XARCHIVE) main.cmx
ocamlfind ocamlopt -o presentation.bin.opt -package "$(REQUIRES)" \
-linkpkg $(XARCHIVE) main.cmx
$(ARCHIVE): $(OBJECTS)
$(OCAMLC) -a -o $(ARCHIVE) $(OBJECTS)
$(XARCHIVE): $(XOBJECTS)
$(OCAMLOPT) -a -o $(XARCHIVE) $(XOBJECTS)
#----------------------------------------------------------------------
# general rules:
OPTIONS =
OCAMLC = ocamlc -g $(OPTIONS) $(ROPTIONS)
OCAMLOPT = ocamlopt -p $(OPTIONS) $(ROPTIONS)
OCAMLDEP = ocamldep $(OPTIONS)
OCAMLFIND = ocamlfind
depend: *.ml *.mli
$(OCAMLDEP) *.ml *.mli >depend
depend.pkg: Makefile
$(OCAMLFIND) use -p ROPTIONS= $(REQUIRES) >depend.pkg
.SUFFIXES: .cmo .cmi .cmx .ml .mli .mll .mly
.ml.cmx:
$(OCAMLOPT) -c $<
.ml.cmo:
$(OCAMLC) -c -g $<
.mli.cmi:
$(OCAMLC) -c $<
.mll.ml:
ocamllex $<
*.mli:
include depend
include depend.pkg
(* $Id: main.ml,v 1.1 2001/01/13 23:10:31 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Pxp_types
open Pxp_document
open Pxp_yacc
let rec print_error e =
prerr_endline (string_of_exn e)
;;
let run f x =
try f x with
e -> print_error e;
exit 1
;;
let convert_to_html filename no_gifs remove_prefix =
(* read in style definition *)
let idx = (new hash_index :> To_html.shared index) in
let document =
parse_document_entity
~id_index: idx
default_config
(from_file filename)
To_html.tag_map
in
let root = document # root in
let store = new To_html.store remove_prefix in
if no_gifs then store # no_gifs;
root # extension # enumerate_pages 0;
let hier = root # extension # collect_hierarchy idx in
store # set_hierarchy hier;
root # extension # print_pages store idx
;;
let main() =
let no_gifs = ref false in
let remove = ref "" in
let filename = ref None in
Arg.parse
[ "-nogifs", Arg.Set no_gifs,
" do not invoke THE GIMP to create icons";
"-remove", Arg.String (fun s -> remove := s),
" remove this prefix from all URLs";
]
(fun s ->
match !filename with
None -> filename := Some s
| Some _ ->
raise (Arg.Bad "Multiple arguments not allowed."))
"usage: presentation [ -nogifs ] [ -remove <prefix> ] input.xml";
let fn =
match !filename with
None ->
prerr_endline "presentation: no input";
exit 1
| Some s -> s
in
run (convert_to_html fn !no_gifs) !remove
;;
main();;
(* ======================================================================
* History:
*
* $Log: main.ml,v $
* Revision 1.1 2001/01/13 23:10:31 gerd
* Initial revision.
*
*)
#! /bin/sh
# $1: The text of the headline. If double quotes or backslashes are used in this
# text, they must be quoted by another backslash.
# $2: The filename where to store the GIF
# $3: The font
# $4: The size of the headline in pixels
# $5: The text color, as hex triple (e.g. 0055aa)
# $6: The highlight color
# $7: The side color
# $8: The shadow color
# $9: The background color
echo "*** Creating $2"
rm -f "$2"
test -f "$2" && exit 1 # If I can't write in this directory, exit now
gimp -n -b "(begin (load \"$PRESENTATION/make-headline.scm\") (make-headline \"$1\" \"$2\" \"$3\" $4 \"$5\" \"$6\" \"$7\" \"$8\" \"$9\" ))" '(gimp-quit 0)'
# The exit code of this script is the code of the following test:
test -f "$2"
; Start this script with:
; gimp -b '(begin (load "make-headline.scm") (make-headline "berschrift" "headline.gif"))' '(gimp-quit 0)'
;**********************************************************************
;From: gimp-headers.scm
;**********************************************************************
; The GIMP -- an image manipulation program
; Copyright (C) 1995 Spencer Kimball and Peter Mattis
;
; www.gimp.org web headers
; Copyright (c) 1997 Adrian Likins
; aklikins@eos.ncsu.edu
;
; based on a idea by jtl (Jens Lautenbacher)
; and improved by jtl
;
; 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., 675 Mass Ave, Cambridge, MA 02139, USA.
;
; **NOTE** This fonts use some very common fonts, that are typically
; bitmap fonts on most installations. If you want better quality versions
; you need to grab the urw font package form www.gimp.org/fonts.html
; and install as indicated. This will replace the some current bitmap fonts
; with higher quality vector fonts. This is how the actual www.gimp.org
; logos were created.
;
; ************************************************************************
; Changed on Feb 4, 1999 by Piet van Oostrum <piet@cs.uu.nl>
; For use with GIMP 1.1.
; All calls to gimp-text-* have been converted to use the *-fontname form.
; The corresponding parameters have been replaced by an SF-FONT parameter.
; ************************************************************************
(define (cadddr list)
(car (cdddr list)))
(define (cddddr list)
(cdr (cdddr list)))
(define (text-fontname image drawable x y text border antialias size size-type
font)
(letrec
((split-fontname
(lambda (k0 k)
(if (< k (string-length font))
(let ((c (substring font k (+ k 1))))
(if (equal? c "-")
(let ((piece (substring font k0 k)))
(cons piece (split-fontname (+ k 1) (+ k 1))))
(split-fontname k0 (+ k 1))))
(list (substring font k0 k)))))
)
(let* ((fontlist (cdr (split-fontname 0 0)))
(foundry (car fontlist))
(family (cadr fontlist))
(weight (caddr fontlist))
(slant (cadddr fontlist))
(fontlist4 (cddddr fontlist))
(set-width (car fontlist4))
(style (cadr fontlist4))
(pixel-size (caddr fontlist4))
(point-size (cadddr fontlist4))
(fontlist8 (cddddr fontlist4))
(res-x (car fontlist8))
(res-y (cadr fontlist8))
(spacing (caddr fontlist8))
(avg-width (cadddr fontlist8))
(fontlist12 (cddddr fontlist8))
(registry (car fontlist12))
(encoding (cadr fontlist12))
)
; (print image)
; (print drawable)
; (print text)
; (print border)
; (print antialias)
; (print size)
; (print size-type)
; (print foundry)
; (print family)
; (print weight)
; (print slant)
; (print set-width)
; (print spacing)
(gimp-text image drawable x y text border antialias size size-type
foundry family weight slant set-width spacing))
))
(define (my-script-fu-headers-gimp-org text font font-size text-color high-color side-color shadow-color bg-color crop rm-bg index num-colors)
(let* ((img (car (gimp-image-new 256 256 RGB)))
(text-layer (car (text-fontname img -1 0 0
text 30 TRUE font-size PIXELS
font)))
(width (car (gimp-drawable-width text-layer)))
(height (car (gimp-drawable-height text-layer)))
(bg-layer (car (gimp-layer-new img width height RGB_IMAGE "Background" 100 NORMAL)))
(old-fg (car (gimp-palette-get-foreground)))
(old-bg (car (gimp-palette-get-background))))
(gimp-image-disable-undo img)
(gimp-image-resize img width height 0 0)
(gimp-image-add-layer img bg-layer 1)
(gimp-layer-set-preserve-trans text-layer TRUE)
(gimp-palette-set-background text-color)
(gimp-edit-fill img text-layer)
(gimp-palette-set-background bg-color)
(gimp-edit-fill img bg-layer)
(let* ((highlight-layer (car (gimp-layer-copy text-layer TRUE)))
(side-layer (car (gimp-layer-copy text-layer TRUE)))
(shadow-layer (car (gimp-layer-copy text-layer TRUE))))
(gimp-image-add-layer img highlight-layer 1)
(gimp-layer-set-preserve-trans highlight-layer TRUE)
(gimp-image-add-layer img side-layer 1)
(gimp-layer-set-preserve-trans side-layer TRUE)
(gimp-image-add-layer img shadow-layer 1)
(gimp-layer-set-preserve-trans shadow-layer TRUE)
(gimp-palette-set-background high-color)
(gimp-edit-fill img highlight-layer)
(gimp-layer-translate highlight-layer -1 -1)
(gimp-palette-set-background side-color)
(gimp-edit-fill img side-layer)
(gimp-layer-translate side-layer 1 1)
(gimp-palette-set-background shadow-color)
(gimp-edit-fill img shadow-layer)
(gimp-layer-translate shadow-layer 5 5)
(gimp-layer-set-preserve-trans shadow-layer FALSE)
(plug-in-gauss-rle 1 img shadow-layer 5 TRUE TRUE)
(gimp-layer-set-opacity shadow-layer 60)
(gimp-image-lower-layer img shadow-layer)
(gimp-image-lower-layer img shadow-layer))
(set! text-layer (car (gimp-image-flatten img)))
(gimp-layer-add-alpha text-layer)
(if (= rm-bg TRUE)
(begin
(gimp-by-color-select text-layer bg-color
1 REPLACE TRUE FALSE 0 FALSE)
(gimp-edit-clear text-layer)
(gimp-selection-clear img)))
(if (= crop TRUE)
(plug-in-autocrop 1 img text-layer))
(if (= index TRUE)
(gimp-convert-indexed img TRUE num-colors))
(gimp-palette-set-foreground old-fg)
(gimp-palette-set-background old-bg)
(gimp-image-enable-undo img)
; We do not need the image to be displayed:
; ORIG: (gimp-display-new img)
; But we need the image to save it on disk:
img
))
;**********************************************************************
(define (color-triple hexnumber)
(let*
((red-hex (substring hexnumber 0 2))
(green-hex (substring hexnumber 2 4))
(blue-hex (substring hexnumber 4 6))
(red-val (string->number red-hex 16))
(green-val (string->number green-hex 16))
(blue-val (string->number blue-hex 16)))
(list red-val green-val blue-val)))
(define (make-headline text filename font font-size text-color high-color
side-color shadow-color bg-color)
(let*
((header
(my-script-fu-headers-gimp-org
text
font ;"-*-geometric 706-black-r-normal-*-*-*-*-*-p-*-iso8859-1"
font-size
(color-triple text-color) ; '(82 108 159) = 526c9f
(color-triple high-color) ; '(192 220 251) = c0dcfb
(color-triple side-color) ; '(46 74 92) = 2e4a5c
(color-triple shadow-color) ; '(0 0 0) = 000000
(color-triple bg-color) ; '(255 255 255) = ffffff
TRUE
FALSE
TRUE
15)))
(file-gif-save
1
header
header
filename
filename
FALSE
FALSE
1
0)
)
)
; Start this script with:
; gimp -b '(begin (load "make-headline.scm") (make-headline "berschrift" "headline.gif"))' '(gimp-quit 0)'
;**********************************************************************
;From: gimp-headers.scm
;**********************************************************************
; The GIMP -- an image manipulation program
; Copyright (C) 1995 Spencer Kimball and Peter Mattis
;
; www.gimp.org web headers
; Copyright (c) 1997 Adrian Likins
; aklikins@eos.ncsu.edu
;
; based on a idea by jtl (Jens Lautenbacher)
; and improved by jtl
;
; 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., 675 Mass Ave, Cambridge, MA 02139, USA.
;
; **NOTE** This fonts use some very common fonts, that are typically
; bitmap fonts on most installations. If you want better quality versions
; you need to grab the urw font package form www.gimp.org/fonts.html
; and install as indicated. This will replace the some current bitmap fonts
; with higher quality vector fonts. This is how the actual www.gimp.org
; logos were created.
;
; ************************************************************************
; Changed on Feb 4, 1999 by Piet van Oostrum <piet@cs.uu.nl>
; For use with GIMP 1.1.
; All calls to gimp-text-* have been converted to use the *-fontname form.
; The corresponding parameters have been replaced by an SF-FONT parameter.
; ************************************************************************
(define (my-script-fu-headers-gimp-org text font font-size text-color high-color side-color shadow-color bg-color crop rm-bg index num-colors)
(let* ((img (car (gimp-image-new 256 256 RGB)))
(text-layer (car (gimp-text-fontname img -1 0 0
text 30 TRUE font-size PIXELS
font)))
(width (car (gimp-drawable-width text-layer)))
(height (car (gimp-drawable-height text-layer)))
(bg-layer (car (gimp-layer-new img width height RGB_IMAGE "Background" 100 NORMAL)))
(old-fg (car (gimp-palette-get-foreground)))
(old-bg (car (gimp-palette-get-background))))
(gimp-image-undo-disable img) ; old: gimp-image-disable-undo
(gimp-image-resize img width height 0 0)
(gimp-image-add-layer img bg-layer 1)
(gimp-layer-set-preserve-trans text-layer TRUE)
(gimp-palette-set-background text-color)
(gimp-edit-fill text-layer)
(gimp-palette-set-background bg-color)
(gimp-edit-fill bg-layer)
(let* ((highlight-layer (car (gimp-layer-copy text-layer TRUE)))
(side-layer (car (gimp-layer-copy text-layer TRUE)))
(shadow-layer (car (gimp-layer-copy text-layer TRUE))))
(gimp-image-add-layer img highlight-layer 1)
(gimp-layer-set-preserve-trans highlight-layer TRUE)
(gimp-image-add-layer img side-layer 1)
(gimp-layer-set-preserve-trans side-layer TRUE)
(gimp-image-add-layer img shadow-layer 1)
(gimp-layer-set-preserve-trans shadow-layer TRUE)
(gimp-palette-set-background high-color)
(gimp-edit-fill highlight-layer)
(gimp-layer-translate highlight-layer -1 -1)
(gimp-palette-set-background side-color)
(gimp-edit-fill side-layer)
(gimp-layer-translate side-layer 1 1)
(gimp-palette-set-background shadow-color)
(gimp-edit-fill shadow-layer)
(gimp-layer-translate shadow-layer 5 5)
(gimp-layer-set-preserve-trans shadow-layer FALSE)
(plug-in-gauss-rle 1 img shadow-layer 5 TRUE TRUE)
(gimp-layer-set-opacity shadow-layer 60)
(gimp-image-lower-layer img shadow-layer)
(gimp-image-lower-layer img shadow-layer))
(set! text-layer (car (gimp-image-flatten img)))
(gimp-layer-add-alpha text-layer)
(if (= rm-bg TRUE)
(begin
(gimp-by-color-select text-layer bg-color
1 REPLACE TRUE FALSE 0 FALSE)
(gimp-edit-clear text-layer)
(gimp-selection-clear img)))
(if (= crop TRUE)
(plug-in-autocrop 1 img text-layer))
; old: (gimp-convert-indexed img TRUE num-colors)
(if (= index TRUE)
(gimp-convert-indexed img 1 0 num-colors FALSE TRUE ""))
(gimp-palette-set-foreground old-fg)
(gimp-palette-set-background old-bg)
(gimp-image-undo-enable img) ; old: gimp-image-enable-undo
; We do not need the image to be displayed:
; ORIG: (gimp-display-new img)
; But we need the image to save it on disk:
img
))
;**********************************************************************
(define (color-triple hexnumber)
(let*
((red-hex (substring hexnumber 0 2))
(green-hex (substring hexnumber 2 4))
(blue-hex (substring hexnumber 4 6))
(red-val (string->number red-hex 16))
(green-val (string->number green-hex 16))
(blue-val (string->number blue-hex 16)))
(list red-val green-val blue-val)))
(define (make-headline text filename font font-size text-color high-color
side-color shadow-color bg-color)
(let*
((header
(my-script-fu-headers-gimp-org
text
font ;"-*-geometric 706-black-r-normal-*-*-*-*-*-p-*-iso8859-1"
font-size
(color-triple text-color) ; '(82 108 159) = 526c9f
(color-triple high-color) ; '(192 220 251) = c0dcfb
(color-triple side-color) ; '(46 74 92) = 2e4a5c
(color-triple shadow-color) ; '(0 0 0) = 000000
(color-triple bg-color) ; '(255 255 255) = ffffff
TRUE
FALSE
TRUE
15)))
(file-gif-save
1
header
header
filename
filename
FALSE
FALSE
1
0)
)
)
; Start this script with:
; gimp -b '(begin (load "make-headline.scm") (make-headline "berschrift" "headline.gif"))' '(gimp-quit 0)'
;**********************************************************************
;From: gimp-headers.scm
;**********************************************************************
; The GIMP -- an image manipulation program
; Copyright (C) 1995 Spencer Kimball and Peter Mattis
;
; www.gimp.org web headers
; Copyright (c) 1997 Adrian Likins
; aklikins@eos.ncsu.edu
;
; based on a idea by jtl (Jens Lautenbacher)
; and improved by jtl
;
; 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., 675 Mass Ave, Cambridge, MA 02139, USA.
;
; **NOTE** This fonts use some very common fonts, that are typically
; bitmap fonts on most installations. If you want better quality versions
; you need to grab the urw font package form www.gimp.org/fonts.html
; and install as indicated. This will replace the some current bitmap fonts
; with higher quality vector fonts. This is how the actual www.gimp.org
; logos were created.
;
; ************************************************************************
; Changed on Feb 4, 1999 by Piet van Oostrum <piet@cs.uu.nl>
; For use with GIMP 1.1.
; All calls to gimp-text-* have been converted to use the *-fontname form.
; The corresponding parameters have been replaced by an SF-FONT parameter.
; ************************************************************************
(define (my-script-fu-headers-gimp-org text font font-size text-color high-color side-color shadow-color bg-color crop rm-bg index num-colors)
(let* ((img (car (gimp-image-new 256 256 RGB)))
(text-layer (car (gimp-text-fontname img -1 0 0
text 30 TRUE font-size PIXELS
font)))
(width (car (gimp-drawable-width text-layer)))
(height (car (gimp-drawable-height text-layer)))
(bg-layer (car (gimp-layer-new img width height RGB_IMAGE "Background" 100 NORMAL)))
(old-fg (car (gimp-palette-get-foreground)))
(old-bg (car (gimp-palette-get-background))))
(gimp-image-disable-undo img)
(gimp-image-resize img width height 0 0)
(gimp-image-add-layer img bg-layer 1)
(gimp-layer-set-preserve-trans text-layer TRUE)
(gimp-palette-set-background text-color)
(gimp-edit-fill text-layer)
(gimp-palette-set-background bg-color)
(gimp-edit-fill bg-layer)
(let* ((highlight-layer (car (gimp-layer-copy text-layer TRUE)))
(side-layer (car (gimp-layer-copy text-layer TRUE)))
(shadow-layer (car (gimp-layer-copy text-layer TRUE))))
(gimp-image-add-layer img highlight-layer 1)
(gimp-layer-set-preserve-trans highlight-layer TRUE)
(gimp-image-add-layer img side-layer 1)
(gimp-layer-set-preserve-trans side-layer TRUE)
(gimp-image-add-layer img shadow-layer 1)
(gimp-layer-set-preserve-trans shadow-layer TRUE)
(gimp-palette-set-background high-color)
(gimp-edit-fill highlight-layer)
(gimp-layer-translate highlight-layer -1 -1)
(gimp-palette-set-background side-color)
(gimp-edit-fill side-layer)
(gimp-layer-translate side-layer 1 1)
(gimp-palette-set-background shadow-color)
(gimp-edit-fill shadow-layer)
(gimp-layer-translate shadow-layer 5 5)
(gimp-layer-set-preserve-trans shadow-layer FALSE)
(plug-in-gauss-rle 1 img shadow-layer 5 TRUE TRUE)
(gimp-layer-set-opacity shadow-layer 60)
(gimp-image-lower-layer img shadow-layer)
(gimp-image-lower-layer img shadow-layer))
(set! text-layer (car (gimp-image-flatten img)))
(gimp-layer-add-alpha text-layer)
(if (= rm-bg TRUE)
(begin
(gimp-by-color-select text-layer bg-color
1 REPLACE TRUE FALSE 0 FALSE)
(gimp-edit-clear text-layer)
(gimp-selection-clear img)))
(if (= crop TRUE)
(plug-in-autocrop 1 img text-layer))
(if (= index TRUE)
(gimp-convert-indexed img TRUE num-colors))
(gimp-palette-set-foreground old-fg)
(gimp-palette-set-background old-bg)
(gimp-image-enable-undo img)
; We do not need the image to be displayed:
; ORIG: (gimp-display-new img)
; But we need the image to save it on disk:
img
))
;**********************************************************************
(define (color-triple hexnumber)
(let*