From 82196565288f7ff08e1462bfa64937806cb1b1ce Mon Sep 17 00:00:00 2001 From: malc Date: Sun, 3 Apr 2022 14:12:03 +0300 Subject: [PATCH] *** empty log message *** --- .dir-locals.el | 1 - .github/workflows/main.yml | 28 - .mailmap | 4 - .merlin | 1 - .ocp-indent | 2 - BUILDING | 27 - INSTALL | 1 - LICENSE | 4 - README | 7 - Thanks | 29 - adoc/llpp.adoc | 136 -- adoc/llppac.adoc | 33 - ahbs | 3 - build.bash | 351 --- config.ml | 1493 ------------- cutils.c | 66 - cutils.h | 24 - ffi.ml | 63 - genconfstruct.sh | 141 -- glfont.c | 390 ---- glutils.ml | 34 - glutils.mli | 11 - help.ml | 207 -- help.mli | 4 - keys.ml | 23 - keys.mli | 19 - lablGL/COPYRIGHT | 26 - lablGL/gl.ml | 89 - lablGL/gl.mli | 64 - lablGL/glArray.ml | 54 - lablGL/glArray.mli | 62 - lablGL/glClear.ml | 20 - lablGL/glClear.mli | 12 - lablGL/glDraw.ml | 55 - lablGL/glDraw.mli | 42 - lablGL/glFunc.ml | 66 - lablGL/glFunc.mli | 43 - lablGL/glMat.ml | 77 - lablGL/glMat.mli | 37 - lablGL/glMisc.ml | 63 - lablGL/glMisc.mli | 38 - lablGL/glPix.ml | 107 - lablGL/glPix.mli | 80 - lablGL/glTex.ml | 121 -- lablGL/glTex.mli | 53 - lablGL/gl_tags.c | 259 --- lablGL/gl_tags.h | 307 --- lablGL/ml_gl.c | 728 ------- lablGL/ml_gl.h | 133 -- lablGL/ml_glarray.c | 113 - lablGL/ml_raw.c | 506 ----- lablGL/ml_raw.h | 23 - lablGL/raw.ml | 84 - lablGL/raw.mli | 83 - lablGL/raw_tags.h | 11 - link.c | 3681 ------------------------------- main.ml | 4897 ------------------------------------------ main.mli | 0 misc/bistep | 18 - misc/completions/zsh/_llpp | 4 - misc/completions/zsh/_llppac | 7 - misc/cutrel | 8 - misc/gcext.py | 58 - misc/getmupdf.sh | 24 - misc/keys.txt | 22 - misc/links.org | 8 - misc/llpp.inotify | 38 - misc/llppac | 171 -- misc/notes/mupdfref.txt | 6 - misc/notes/pzoom.txt | 22 - parser.ml | 326 --- parser.mli | 18 - todo.org | 47 - uiutils.ml | 796 ------- uiutils.mli | 88 - utf8syms.ml | 4 - utils.ml | 274 --- utils.mli | 70 - version.c | 3 - wsi/cocoa/cocoa.m | 926 -------- wsi/cocoa/genplist.sh | 54 - wsi/cocoa/wsi.ml | 316 --- wsi/x11/keysym2ucs.c | 849 -------- wsi/x11/wsi.ml | 1199 ----------- wsi/x11/wsi.mli | 60 - wsi/x11/xlib.c | 92 - 86 files changed, 20544 deletions(-) delete mode 100644 .dir-locals.el delete mode 100644 .github/workflows/main.yml delete mode 100644 .mailmap delete mode 100644 .merlin delete mode 100644 .ocp-indent delete mode 100644 BUILDING delete mode 100644 INSTALL delete mode 100644 LICENSE delete mode 100644 README delete mode 100644 Thanks delete mode 100644 adoc/llpp.adoc delete mode 100644 adoc/llppac.adoc delete mode 100755 ahbs delete mode 100755 build.bash delete mode 100644 config.ml delete mode 100644 cutils.c delete mode 100644 cutils.h delete mode 100644 ffi.ml delete mode 100644 genconfstruct.sh delete mode 100644 glfont.c delete mode 100644 glutils.ml delete mode 100644 glutils.mli delete mode 100644 help.ml delete mode 100644 help.mli delete mode 100644 keys.ml delete mode 100644 keys.mli delete mode 100644 lablGL/COPYRIGHT delete mode 100644 lablGL/gl.ml delete mode 100644 lablGL/gl.mli delete mode 100644 lablGL/glArray.ml delete mode 100644 lablGL/glArray.mli delete mode 100644 lablGL/glClear.ml delete mode 100644 lablGL/glClear.mli delete mode 100644 lablGL/glDraw.ml delete mode 100644 lablGL/glDraw.mli delete mode 100644 lablGL/glFunc.ml delete mode 100644 lablGL/glFunc.mli delete mode 100644 lablGL/glMat.ml delete mode 100644 lablGL/glMat.mli delete mode 100644 lablGL/glMisc.ml delete mode 100644 lablGL/glMisc.mli delete mode 100644 lablGL/glPix.ml delete mode 100644 lablGL/glPix.mli delete mode 100644 lablGL/glTex.ml delete mode 100644 lablGL/glTex.mli delete mode 100644 lablGL/gl_tags.c delete mode 100644 lablGL/gl_tags.h delete mode 100644 lablGL/ml_gl.c delete mode 100644 lablGL/ml_gl.h delete mode 100644 lablGL/ml_glarray.c delete mode 100644 lablGL/ml_raw.c delete mode 100644 lablGL/ml_raw.h delete mode 100644 lablGL/raw.ml delete mode 100644 lablGL/raw.mli delete mode 100644 lablGL/raw_tags.h delete mode 100644 link.c delete mode 100644 main.ml delete mode 100644 main.mli delete mode 100755 misc/bistep delete mode 100644 misc/completions/zsh/_llpp delete mode 100644 misc/completions/zsh/_llppac delete mode 100755 misc/cutrel delete mode 100644 misc/gcext.py delete mode 100644 misc/getmupdf.sh delete mode 100644 misc/keys.txt delete mode 100644 misc/links.org delete mode 100755 misc/llpp.inotify delete mode 100755 misc/llppac delete mode 100644 misc/notes/mupdfref.txt delete mode 100644 misc/notes/pzoom.txt delete mode 100644 parser.ml delete mode 100644 parser.mli delete mode 100644 todo.org delete mode 100644 uiutils.ml delete mode 100644 uiutils.mli delete mode 100644 utf8syms.ml delete mode 100644 utils.ml delete mode 100644 utils.mli delete mode 100644 version.c delete mode 100644 wsi/cocoa/cocoa.m delete mode 100644 wsi/cocoa/genplist.sh delete mode 100644 wsi/cocoa/wsi.ml delete mode 100644 wsi/x11/keysym2ucs.c delete mode 100644 wsi/x11/wsi.ml delete mode 100644 wsi/x11/wsi.mli delete mode 100644 wsi/x11/xlib.c diff --git a/.dir-locals.el b/.dir-locals.el deleted file mode 100644 index 102d50d..0000000 --- a/.dir-locals.el +++ /dev/null @@ -1 +0,0 @@ -((nil . ((compile-command . "ccd=ccache\\ gcc ./ahbs")))) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml deleted file mode 100644 index 1b0f308..0000000 --- a/.github/workflows/main.yml +++ /dev/null @@ -1,28 +0,0 @@ -name: main - -on: [push, pull_request] - -jobs: - build: - strategy: - fail-fast: false - matrix: - os: - - macos-latest - - ubuntu-latest - - runs-on: ${{ matrix.os }} - - steps: - - name: Checkout - uses: actions/checkout@v2 - - name: download mupdf - run: mkdir build && sh misc/getmupdf.sh build/mupdf - - name: Install prerquisites - if: matrix.os == 'ubuntu-latest' - run: | - sudo apt-get update - sudo apt-get install libgl1-mesa-dev ccache - - name: build - if: matrix.os == 'ubuntu-latest' - run: bash ahbs diff --git a/.mailmap b/.mailmap deleted file mode 100644 index 3f014d9..0000000 --- a/.mailmap +++ /dev/null @@ -1,4 +0,0 @@ -Hendrik Rosendahl -Nicolás Ojeda Bär -Edwin Török - diff --git a/.merlin b/.merlin deleted file mode 100644 index 48260ff..0000000 --- a/.merlin +++ /dev/null @@ -1 +0,0 @@ -B lablGL/** diff --git a/.ocp-indent b/.ocp-indent deleted file mode 100644 index 324a382..0000000 --- a/.ocp-indent +++ /dev/null @@ -1,2 +0,0 @@ -match_clause=4 -strict_with=auto diff --git a/BUILDING b/BUILDING deleted file mode 100644 index 8ba4928..0000000 --- a/BUILDING +++ /dev/null @@ -1,27 +0,0 @@ -Prerequisites for building from sources: - bash [https://en.wikipedia.org/wiki/Bash_(Unix_shell)] - mupdf [https://mupdf.com] - opengl [https://en.wikipedia.org/wiki/OpenGL] - git [https://git-scm.com] - ocaml 4.14.0 [https://ocaml.org] - If not present will be downloaded from the network and - built/used locally without system-wide installation. - This requires either: - wget [https://www.gnu.org/software/wget] - or curl [https://curl.haxx.se] - - asciidoc [https://asciidoc.org/] - Is needed if one wants to build man pages - -To download mupdf+prerequisites that llpp is known to work with: - - mkdir build && sh misc/getmupdf.sh build/mupdf - -To build llpp (binary will be in build/llpp): - - bash build.bash build - - # by default llpp looks for .config/llpp.conf file - # hence .config directory should be present otherwise - # llpp will fail to start - -To build man pages (will be in build/doc/[name].1) - - bash build.bash build doc diff --git a/INSTALL b/INSTALL deleted file mode 100644 index e8269a5..0000000 --- a/INSTALL +++ /dev/null @@ -1 +0,0 @@ -Copy llpp (the executable) somewhere in your path diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 290baf4..0000000 --- a/LICENSE +++ /dev/null @@ -1,4 +0,0 @@ -This code, sans local copy of LablGL [1], is in the public domain [2] - -[1] Text inside lablGL/COPYRIGHT covers lablGL -[2] https://github.com/ccxvii/snippets/blob/master/README covers glfont.c diff --git a/README b/README deleted file mode 100644 index 1749463..0000000 --- a/README +++ /dev/null @@ -1,7 +0,0 @@ - Oh my god it's full of bugs - =========================== - -This is llpp a graphical PDF viewer which aims to superficially -resemble less(1) - -The rendering library used is MuPDF (http://www.mupdf.com/) diff --git a/Thanks b/Thanks deleted file mode 100644 index 32aaf5c..0000000 --- a/Thanks +++ /dev/null @@ -1,29 +0,0 @@ -Whole OCaml team -Jacques Garrigue, Isaac Trotts, Erick Tryzelaar and Christophe Raffali -Krzysztof Kowalczyk -Artifex Software Inc., Tor Andersson, Robin Watts, Sebastian Rasmussen -Alexander Graf, Richard Henderson, Edgar E. Iglesias -Conrad Parker -Michael Witten -Sara Fauzia -John Stuffer -Juergen Lock -Uli Armbruster (autoscroll speed control idea) -Karl Trygve Kalleberg -lu (multicolumn bird's eye idea) -aksr (WM/ICCCM help) -E.A. German (comfy chair, silent x86 box, lots more) -Andrei Gulin (nudge towards split columns) -Torsten Ww (help with Mesa flickering issue and horizontal wheel) -Didier Remy -Edward Allan Kmett -Tuncer Ayaz -Mark Oteiza -Vladimir Murzin -Danir Falerogly Barakhtangerey -Nicolás Ojeda Bär -Nils Becker -Tarek Dakhran -Hendrik Rosendahl -German S. Zhivotnikov -Neil Mitchell diff --git a/adoc/llpp.adoc b/adoc/llpp.adoc deleted file mode 100644 index 3320fc6..0000000 --- a/adoc/llpp.adoc +++ /dev/null @@ -1,136 +0,0 @@ -// -*- mode: flyspell -*- -llpp(1) -======= - -== NAME -llpp - a graphical document pager which aims to superficially resemble -less - -== SYNOPSIS -llpp [-c path] [-css path] [-dest name] [-f path] [-gc] [-help|--help] - [-last] [-no-title] [-origin origin] [-p password] [-page page-number] - [-remote path] [-flip-stderr-redirection] [-v] path-to-the-document - -== DESCRIPTION -*llpp* is a graphical document pager utilizing MuPDF -(https://mupdf.com/) library. The default keybindings resemble those -of less(1) - -== OPTIONS --c path:: -Set path to the configuration file - --css path:: -Set path to the style sheet to use with EPUB/HTML - --f path:: -Set path to the user interface font - --gc:: -Collect config garbage - --help, --help:: -Display list of options - --last:: -Open last visited document - --no-title:: -Ignore document title - --origin origin:: - - --p password:: -Set password - --page page-number:: -Jump to page - --remote path:: -Set path to the source of remote commands - --dest name:: -> - --dcf path:: - - --flip-stderr-redirection:: - - --v:: -Print version and exit - -== KEY BINDINGS -Open a document with llpp, then press `F1` or `alt-h` to switch to help mode. - -== FILES - -=== $HOME/.config/llpp.conf -This is the user specific configuration file. If $HOME/.config -directory does not exist $HOME/llpp.conf is used instead. It has an -XML structure. - -.Configuration structure -------------------------------------------------------------- - - - - - - ... - -------------------------------------------------------------- - -==== Some configuration tips -- To change the user interface font: -------------------------------------------------------------- - - - - -------------------------------------------------------------- -- To change keybindings, add keymaps to the defaults element, for -instance following example disables Escape key in the view mode: - -------------------------------------------------------------- - - - - - - - -------------------------------------------------------------- - -The different modes are _birdseye_, _global_, _help_, _info_, -_listview_, _outline_, and _view_. - -== SEE ALSO -llppac(1), llpphtml(1) - -== ENVIRONMENT -=== LLPP_ASKPASS -Command to inquire user about the password (dmenu/rofi like) - -=== LLPP_FALLBACK_FONT - -Path to the substitution font -(such as https://github.com/unicode-org/last-resort-font/ for instance) - -== REPORTING BUGS -https://github.com/moosotc/llpp/issues - -== macOS -Nicolás Ojeda Bär contributed macOS port. diff --git a/adoc/llppac.adoc b/adoc/llppac.adoc deleted file mode 100644 index 1ea24e5..0000000 --- a/adoc/llppac.adoc +++ /dev/null @@ -1,33 +0,0 @@ -llppac(1) -========= - -== NAME -llppac - an auto converter that will try to show anything via llpp - -== SYNOPSIS -llppac [-c css] [-m type] [-t type] [-f] (path|url) - -== DESCRIPTION -*llppac* script will try to convert document backed by supplied argument -and run llpp(1) on the result. The conversion result will be cached. - -== OPTIONS --c path:: -Path to CSS file - --f:: -Disregard the cache - --m type:: -Set the mime type manually. Set by file(1) --mime-type otherwise. - --t type:: -Set the type of the the document, totally skipping the mime type -check. The type is llppac internal, possible values include, but are -not limited to _ps_, _texi_, _djvu_, _html_ - -== SEE ALSO -llpp(1) - -== REPORTING BUGS -https://github.com/moosotc/llpp/issues diff --git a/ahbs b/ahbs deleted file mode 100755 index 0bf42a9..0000000 --- a/ahbs +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash -ccd=${ccd-ccache gcc}; export CC=$ccd CXX=$ccd CAML_CC=$ccd -exec time -p ${bash-bash} build.bash build "$@" diff --git a/build.bash b/build.bash deleted file mode 100755 index 704394f..0000000 --- a/build.bash +++ /dev/null @@ -1,351 +0,0 @@ -#!/bin/bash -set -eu - -vecho() { ${vecho-:} "$@"; } -executable_p() { command -v "$1" >/dev/null 2>&1; } -dgst='cksum "$@" | while read d _; do printf $d; done' -! executable_p b3sum || dgst='b3sum --no-names "$@"' -executable_p realpath || realpath() (cd "$1" &>/dev/null; pwd -P) -eval "digest() { $dgst; } 2>/dev/null" -die() { echo "$@" >&2; exit 111; } -trap 'test $? -eq 0 || echo "build failed"' EXIT - -darwin=false -wsid="wsi/x11" -clip="LC_CTYPE=UTF-8 xclip -i" -paste="LC_CTYPE=UTF-8 xclip -o" -uopen="echo 'Open "%s"' >&2" -print="echo 'Print "%s"' >&2" -mjobs=$(getconf _NPROCESSORS_ONLN || echo 1) -case "$(uname)" in - Darwin) - darwin=true - wsid="wsi/cocoa" - clip="LC_CTYPE=UTF-8 pbcopy" - paste="LC_CTYPE=UTF-8 pbaste" - uopen='open "%s"';; - Linux) ;; - *) die $(uname) is not supported;; -esac - -test -n "${1-}" || die "usage: $0 build-directory" - -outd=$1 -srcd=$(dirname $0) -mudir=$outd/mupdf -muinc="-I $mudir/include -I $mudir/thirdparty/freetype/include" - -test -d $mudir || die muPDF wasn\'t found in $outd/, consult $srcd/BUILDING - -mkdir -p $outd/{$wsid,lablGL} - -isfresh() { test "$(<$1.past)" = "$2"; } 2>/dev/null - -mbt=${mbt:-release} -test -n "${gmk:-}" && gmk=false || gmk=true - -mulibs="$mudir/build/$mbt/libmupdf.a $mudir/build/$mbt/libmupdf-third.a" -make="make -C "$mudir" build=$mbt -j $mjobs libs" -$make -q -s || $make - -oincs() { - local b=$1 incs - case "${2#$outd/}" in - $wsid/wsi.cm[oi]|confstruct.cmo|help.cmo) incs="-I $b -I $b/$wsid";; - glutils.cmo) incs="-I $b -I $b/lablGL";; - uiutils.cmo|main.cmo) incs="-I $b -I $b/$wsid -I $b/lablGL";; - ffi.cmo|help.cmi|parser.cmo) incs="-I $b";; - config.cmo) - incs="-I $b -I $b/$wsid" - test "$b" = $outd || incs="$incs -I $outd" - ;; - lablGL/*) incs="-I $b/lablGL";; - main.cmo|keys.cmo|utils.cmo|utf8syms.cmo) incs="-I $b";; - config.cmi) incs="-I $outd -I $b -I $b/$wsid";; - uiutils.cmi|ffi.cmi) incs="-I $b";; - glutils.cmi) incs="-I $b/lablGL";; - main.cmi|keys.cmi|utils.cmi|utf8syms.cmi|parser.cmi) ;; - *) die "ocaml include paths for '$2' aren't set";; - esac - test -z "${incs-}" || echo $incs -} - -oflags() { - case "${1#$outd/}" in - lablGL/*) f="-g";; - utf8syms.cmo|confstruct.cmo|config.cmo|ffi.cmo|wsi/cocoa/wsi.cmo) - f="-g -strict-sequence -strict-formats -alert @all-missing-mli";; - *) f="-g -strict-sequence -strict-formats -alert @all -warn-error @A";; - esac - echo $(oincs $outd $1) $f -} - -cflags() { - case "${1#$outd/}" in - version.o) f=-DLLPP_VERSION=$ver;; - lablGL/*.o) f="-g -Wno-pointer-sign -Werror -O2";; - link.o) - f="-g -std=c11 $muinc -Wall -Werror -Wextra -pedantic " - test "${mbt-}" = "debug" || f+="-O2 " - $darwin && f+="-DMACOS -D_GNU_SOURCE -DGL_H=''" \ - || f+="-D_POSIX_C_SOURCE -DGL_H=''" - f+=" -DTEXT_TYPE=GL_TEXTURE_RECTANGLE_ARB" - #f+=" -DLLPARANOIDP" - #f+=" -DTEXT_TYPE=GL_TEXTURE_2D" - ;; - *) f="-g -O2 -Wall -Werror";; - esac - ! $darwin || f+=" -DGL_SILENCE_DEPRECATION" - echo $f -} - -mflags() { - echo "-I $(ocamlc -where) -g -Wall -Werror -O2 -DGL_SILENCE_DEPRECATION" -} - -overs=$(ocamlc -vnum 2>/dev/null) || overs="" -if test "$overs" != "4.14.0~rc1"; then - url=https://caml.inria.fr/pub/distrib/ocaml-4.14/ocaml-4.14.0~rc1.tar.xz - txz=$outd/$(basename $url) - keycmd="printf $url; digest $txz;" - isfresh $txz "$(eval $keycmd)" || { - if executable_p wget; then dl() { wget "$1" -O "$2"; } - elif executable_p curl; then dl() { curl -L "$1" -o "$2"; } - else die "no program to fetch remote urls found" - fi - dl $url $txz - eval $keycmd >$txz.past - } && vecho "fresh $txz" - absprefix=$(realpath $outd) - export PATH=$absprefix/bin:$PATH - ocamlc=$absprefix/bin/ocamlc - keycmd="printf $url; digest $ocamlc;" - isfresh $ocamlc "$(eval $keycmd)" || ( - # This will needlessly re{configure,make} ocaml since "past" - # of configure/make is hard to ascertain. "Better safe than - # sorry" approach is taken here. The check will work for a - # single ocaml url/version, but _will_ redo _everything_ - # otherwise (even if fully built artifacts are available) - tar xf $txz -C $outd - bn=$(basename $url) - cd $outd/${bn%.tar.xz} - ./configure --disable-ocamldoc --disable-ocamltest \ - --enable-debugger=no --prefix=$absprefix - make -j $mjobs world - make install - eval $keycmd >$absprefix/bin/ocamlc.past - ) && vecho "fresh ocamlc" - overs=$(ocamlc -vnum 2>/dev/null) -fi - -while read k v; do - case "$k" in - "bytecomp_c_compiler:") ccomp=${CAML_CC-$v};; - "word_size:") ! test "$darwin$v" = "true32" || die "need 64bit ocaml";; - esac -done < <(ocamlc -config) - -read cvers < <($ccomp --version) - -seen= -ord= -$gmk || :>$outd/Makefile -bocaml1() { - local n=$1 s=$2 o=$3 deps= cmd d - local keycmd="digest $s $o.depl" - cmd="ocamlc -depend -bytecode -one-line $(oincs $srcd $o) $s" - - isfresh "$o.depl" "$overs$cmd$(eval $keycmd)" || { - read _ _ depl < <(eval $cmd) || die "$cmd failed" - for d in $depl; do - if test "$d" = "$outd/confstruct.cmo"; - then d=confstruct.cmo; else d=${d#$srcd/}; fi - deps+="$d\n" - done - printf "$deps" >$o.depl - deps= - echo "$overs$cmd$(eval $keycmd)" >"$o.depl.past" - } && vecho "fresh $o.depl" - - # this saves time but is overly optimistic as interface (dis) - # appearance will result in an invalid (stale) .depl (cache). not - # using a cache is correct but slow(er (much)) way to handle this. - while read d; do - bocaml $d $((n+1)) - deps+=" $outd/$d" - done <$o.depl - - cmd="ocamlc $(oflags $o) -c -o $o $s" - keycmd="digest $o $s $deps" - isfresh "$o" "$overs$cmd$(eval $keycmd)" || { - printf "%*.s%s\n" $n '' "${o#$outd/}" - eval "$cmd" || die "$cmd failed" - echo "$overs$cmd$(eval $keycmd)" >"$o.past" - } && vecho "fresh $o" - $gmk || printf "$o: $deps\n\t%s\n" "$cmd" >>$outd/Makefile - seen+=$o - ord+=" $o" -} - -cycle= -bocaml() { - [[ ! $seen =~ $1 ]] || return 0 - local s o=$1 n=$2 cycle1=$cycle - case $o in - confstruct.cmo) s=$outd/confstruct.ml;; - *.cmo) s=$srcd/${o%.cmo}.ml;; - *.cmi) s=$srcd/${o%.cmi}.mli;; - esac - o=$outd/$o - [[ "$cycle" =~ "$o" ]] && die cycle $o || cycle=$cycle$o - bocaml1 $n $s $o - cycle=$cycle1 -} - -baux() { - local o=$1 cmd=$2 - read 2>/dev/null _ d <$o.dep || d= - local keycmd='digest $o $d' - isfresh "$o" "$cvers$cmd$(eval $keycmd)" || { - echo "${o#$outd/}" - eval "$cmd" || die "$cmd failed" - read _ d <$o.dep - echo "$cvers$cmd$(eval $keycmd)" >"$o.past" - } && vecho "fresh $o" - $gmk || printf "$o: $d\n\t$cmd\n" >>$outd/Makefile -} - -bocamlc() { - local o=$outd/$1 s=$srcd/${1%.o}.c cc=${CAML_CC:+-cc "'$CAML_CC'" } - baux $o "ocamlc $cc-ccopt \"$(cflags $o) -MMD -MF $o.dep -MT_\" -o $o -c $s" -} - -bobjc() { - local o=$outd/$1 - baux $o "$mcomp $(mflags $o) -MD -MF $o.dep -MT_ -c -o $o $srcd/${1%.o}.m" -} - -ver=$(cd $srcd && git describe --tags --dirty) || ver="'built on $(date)'" - -gen=$srcd/genconfstruct.sh -out=$outd/confstruct.ml -cmd="(export print paste clip uopen; . $gen >$out)" -keycmd="{ echo '$print $paste $clip $uopen'; digest $gen $out; }" -isfresh "$out" "$cmd$(eval $keycmd)" || { - echo "generating $out" - eval "$cmd" || die $gen failed - echo "$cmd$(eval $keycmd)" > "${out}.past" -} && vecho "fresh $out" - -shift 1 -for target; do - case "$target" in - doc) - md=$outd/doc - mkdir -p $md - for m in llpp llppac; do - src=$srcd/adoc/$m.adoc - o=$md/$m.1 - conf=$srcd/man/asciidoc.conf - keycmd="digest $o $src $conf" - cmd="a2x -f manpage -D $md $src" - isfresh "$o" "$cmd$(eval $keycmd)" || { - echo "${o#$outd/}" - eval "$cmd" || die "$cmd failed" - echo "$cmd$(eval $keycmd)" >"$o.past" - } && vecho "fresh $o" - done; - exit;; - *) die "no such target - '$target'";; - esac -done - -flatten() { - local o - [[ ! "$seen" =~ "$1" ]] || return 0 - bocaml $1 0 - for o in $ord; do - local wooutd=${o#$outd/} - case $o in - *.cmi) flatten ${wooutd%.cmi}.cmo;; - *.cmo) flatten $wooutd;; - esac - done -} -flatten main.cmo - -modules= -collectmodules() { - # it might appear that following can be done inside bocaml* but - # alas due to the early cmi->cmo descent this ought to be done - # here (at least the solution inside bocaml* eludes me) - local dep cmo this=$1 - while read dep; do - case $dep in - *.cmi) - cmo=${dep%.cmi}.cmo - test $cmo = $this || collectmodules $cmo - ;; - *.cmo) - collectmodules $dep - cmo=$dep - ;; - esac - [[ $modules =~ $cmo ]] || modules+=" $outd/$cmo" - done <$outd/$1.depl -} -collectmodules main.cmo - -cobjs= -for m in link cutils version; do - bocamlc $m.o - cobjs+=" $outd/$m.o" -done -for m in ml_gl ml_glarray ml_raw; do - bocamlc lablGL/$m.o - cobjs+=" $outd/lablGL/$m.o" -done - -libs="str.cma unix.cma" -clibs="-L$mudir/build/$mbt -lmupdf -lmupdf-third -lpthread" -if $darwin; then - mcomp=$ccomp - clibs+=" -framework Cocoa -framework OpenGL" - cobjs+=" $outd/wsi/cocoa/cocoa.o" - bobjc wsi/cocoa/cocoa.o -else - clibs+=" -lGL -lX11" - cobjs+=" $outd/wsi/x11/keysym2ucs.o $outd/wsi/x11/xlib.o" - bocamlc wsi/x11/keysym2ucs.o - bocamlc wsi/x11/xlib.o -fi - -cmd="ocamlc -custom $libs -o $outd/llpp $cobjs $modules -cclib \"$clibs\"" -keycmd="digest $outd/llpp $cobjs $modules $mulibs" -isfresh "$outd/llpp" "$cmd$(eval $keycmd)" || { - echo linking $outd/llpp - eval "$cmd" || die "$cmd failed" - echo "$cmd$(eval $keycmd)" >"$outd/llpp.past" -} && vecho "fresh llpp" -$gmk || printf "$outd/llpp: $cobjs $modules $mulibs\n\t$cmd\n" >>$outd/Makefile - -if $darwin; then - out="$outd/llpp.app/Contents/Info.plist" - keycmd="digest $out $srcd/wsi/cocoa/genplist.sh; echo $ver" - isfresh $out "$(eval $keycmd)" || { - d=$(dirname $out) - mkdir -p "$d" - echo "generating $out" - (. $srcd/wsi/cocoa/genplist.sh) >"$out" - eval $keycmd>"$out.past" - } && vecho "fresh plist" - - out=$outd/llpp.app/Contents/MacOS/llpp - keycmd="digest $out $outd/llpp" - isfresh $out "$(eval $keycmd)" || { - echo "bundling $out" - mkdir -p "$(dirname $out)" - cp $outd/llpp $out - eval $keycmd>"$out.past" - } && vecho "fresh bundle" -fi diff --git a/config.ml b/config.ml deleted file mode 100644 index 6c28f9a..0000000 --- a/config.ml +++ /dev/null @@ -1,1493 +0,0 @@ -open Utils - -let irect_of_string s = - Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1)) - -let irect_to_string (x0,y0,x1,y1) = Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1 - -let multicolumns_to_string (n, a, b) = - if a = 0 && b = 0 - then Printf.sprintf "%d" n - else Printf.sprintf "%d,%d,%d" n a b - -let multicolumns_of_string s = - try - (int_of_string s, 0, 0) - with _ -> - Scanf.sscanf s "%u,%u,%u" (fun n a b -> - if a > 1 || b > 1 - then error "subtly broken"; - (n, a, b) - ) - -include Confstruct - -type angle = int -and opaque = Opaque.t -and rectcolor = rgba -and pixmapsize = int -and gen = int -and top = float -and dtop = float -and fontpath = string -and trimmargins = bool -and trimparams = (trimmargins * irect) -and uri = string -and caption = string -and tilex = int -and tiley = int -and tileparams = (x * y * w * h * tilex * tiley) -and under = - | Unone - | Ulinkuri of string - | Utext of facename - | Utextannot of (opaque * slinkindex) - | Ufileannot of (opaque * slinkindex) -and slinkindex = int -and facename = string -and launchcommand = string -and filename = string -and linkno = int -and destname = string -and link = - | Lnotfound - | Lfound of int -and linkdir = - | LDfirst - | LDlast - | LDfirstvisible of (int * int * int) - | LDleft of int - | LDright of int - | LDdown of int - | LDup of int -and pagewithlinks = - | Pwlnotfound - | Pwl of int -and anchor = pageno * top * dtop -and rect = float * float * float * float * float * float * float * float -and infochange = | Memused | Docinfo | Pdim -and redirstderr = bool -and fontstate = - { mutable fontsize : int - ; mutable wwidth : float - ; mutable maxrows : int - } - -let fstate = - { fontsize = Wsi.fontsizescale 20 - ; wwidth = nan - ; maxrows = -1 - } - -class type uioh = - object - method display : unit - method key : int -> int -> uioh - method button : int -> bool -> int -> int -> int -> uioh - method multiclick : int -> int -> int -> int -> uioh - method motion : int -> int -> uioh - method pmotion : int -> int -> uioh - method infochanged : infochange -> unit - method scrollpw : (int * float * float) - method scrollph : (int * float * float) - method modehash : keyhash - method eformsgs : bool - method alwaysscrolly : bool - method scroll : int -> int -> uioh - method zoom : float -> int -> int -> unit - end - -module type TextEnumType = sig - type t - val name : string - val names : string array -end - -module TextEnumMake (Ten : TextEnumType) = struct - let names = Ten.names - let to_int (t : Ten.t) = Obj.magic t - let to_string t = names.(to_int t) - let of_int n : Ten.t = Obj.magic n - let of_string s = - let rec find i = - if i = Array.length names - then error "invalid %s: %s" Ten.name s - else ( - if Ten.names.(i) = s - then of_int i - else find (i+1) - ) - in find 0 -end - -module CSTE = TextEnumMake (struct - type t = colorspace - let name = "colorspace" - let names = [|"rgb"; "gray"|] - end) - -module MTE = TextEnumMake (struct - type t = mark - let name = "mark" - let names = [|"page"; "block"; "line"; "word"|] - end) - -module FMTE = TextEnumMake (struct - type t = fitmodel - let name = "fitmodel" - let names = [|"width"; "proportional"; "page"|] - end) - -type outlinekind = - | Onone - | Oanchor of anchor - | Ouri of uri - | Olaunch of launchcommand - | Oremote of (filename * pageno) - | Oremotedest of (filename * destname) - | Ohistory of (filename * conf * outline list * x * anchor * filename) -and outline = (caption * outlinelevel * outlinekind) -and outlinelevel = int - -type page = - { pageno : int - ; pagedimno : int - ; pagew : int - ; pageh : int - ; pagex : int - ; pagey : int - ; pagevw : int - ; pagevh : int - ; pagedispx : int - ; pagedispy : int - ; pagecol : int - } - -type tile = opaque * pixmapsize * elapsed -and elapsed = float -and pagemapkey = pageno * gen -and tilemapkey = pageno * gen * colorspace * angle * w * h * col * row -and row = int -and col = int -and currently = - | Idle - | Loading of (page * gen) - | Tiling - of (page * opaque * colorspace * angle * gen * col * row * w * h) - | Outlining of outline list -and mpos = int * int -and mstate = - | Mnone - | Msel of (mpos * mpos) - | Mpan of mpos - | Mscrolly | Mscrollx - | Mzoom of (buttonno * step * mpos) - | Mzoomrect of (mpos * mpos) -and buttonno = int -and step = int -and mode = - | View - | Birdseye of (conf * leftx * pageno * pageno * anchor) - | Textentry of (textentry * onleave) - | LinkNav of linktarget -and onleave = leavetextentrystatus -> unit -and leavetextentrystatus = | Cancel | Confirm -and helpitem = string * int * action -and action = (uioh -> uioh) option -and linktarget = - | Ltexact of (pageno * direction) - | Ltgendir of direction - | Ltnotready of (pageno * direction) -and direction = int (* -1, 0, 1 *) -and textentry = string * string * onhist option * onkey * ondone * cancelonempty -and onkey = string -> Keys.t -> te -and ondone = string -> unit -and histcancel = unit -> unit -and onhist = ((histcmd -> string) * histcancel) -and histcmd = HCnext | HCprev | HCfirst | HClast -and cancelonempty = bool -and te = - | TEstop - | TEdone of string - | TEcont of string - | TEswitch of textentry -and 'a circbuf = - { store : 'a array - ; mutable rc : int - ; mutable wc : int - ; mutable len : int - } -and 'a nav = - { past : 'a list - ; future : 'a list - } - -let emptykeyhash = Hashtbl.create 0 -let noreprf () = () -let noroamf () = () - -let nouioh : uioh = - object (self) - method display = () - method key _ _ = self - method multiclick _ _ _ _ = self - method button _ _ _ _ _ = self - method motion _ _ = self - method pmotion _ _ = self - method infochanged _ = () - method scrollpw = (0, nan, nan) - method scrollph = (0, nan, nan) - method modehash = emptykeyhash - method eformsgs = false - method alwaysscrolly = false - method scroll _ _ = self - method zoom _ _ _ = () - end - -let cbnew n v = - { store = Array.make n v - ; rc = 0 - ; wc = 0 - ; len = 0 - } - -let cbcap b = Array.length b.store - -let cbput ?(update_rc=true) b v = - let cap = cbcap b in - b.store.(b.wc) <- v; - b.wc <- (b.wc + 1) mod cap; - if update_rc - then b.rc <- b.wc; - b.len <- min (b.len + 1) cap - -let cbput_dont_update_rc b v = cbput ~update_rc:false b v - -let cbempty b = b.len = 0 - -let cbgetg b circular dir = - if cbempty b - then b.store.(0) - else - let rc = b.rc + dir in - let rc = - if circular - then ( - if rc = -1 - then b.len-1 - else ( - if rc >= b.len - then 0 - else rc - ) - ) - else bound rc 0 (b.len-1) - in - b.rc <- rc; - b.store.(rc) - -let cbget b = cbgetg b false -let cbgetc b = cbgetg b true - -type hists = - { pat : string circbuf - ; pag : string circbuf - ; sel : string circbuf - } - -let home = - try Sys.getenv "HOME" - with exn -> - dolog "cannot determine home directory location: %s" @@ exntos exn; - E.s - -module S = struct - let confpath = ref E.s - let ss = ref Unix.stdin - let wsfd = ref Unix.stdin - let stderr = ref Unix.stdin - let selfexec = ref E.s - let ignoredoctitlte = ref false - let errmsgs = Buffer.create 0 - let newerrmsgs = ref false - let w = ref max_int - let x = ref max_int - let y = ref max_int - let xf = ref 0.0 - let yf = ref 0.0 - let anchor = ref E.j - let ranchors : (string * string * string * anchor * string) list ref = ref [] - let maxy = ref max_int - let layout : page list ref = ref [] - let pagemap : (pagemapkey, opaque) Hashtbl.t = Hashtbl.create 0 - let tilemap : (tilemapkey, tile) Hashtbl.t = Hashtbl.create 0 - let pdims : (pageno * w * h * leftx) list ref = ref [] - let pagecount = ref max_int - let currently = ref Idle - let mstate = ref Mnone - let searchpattern = ref E.s - let rects : (pageno * rectcolor * rect) list ref = ref [] - let rects1 : (pageno * rectcolor * rect) list ref = ref [] - let text = ref E.s - let path = ref E.s - let password = ref E.s - let mimetype = ref E.s - let nameddest = ref E.s - let origin = ref E.s - let winstate : Wsi.winstate list ref = ref [] - let mode : mode ref = ref View - let uioh : uioh ref = ref nouioh - let outlines : outline array ref = ref [||] - let bookmarks : outline list ref = ref [] - let geomcmds : (string * ((string * (unit -> unit)) list)) ref - = ref (E.s, []) - let memused : memsize ref = ref 0 - let gen : gen ref = ref 0 - let autoscroll : int option ref = ref None - let help : helpitem array ref = ref E.a - let docinfo : (int * string) list ref = ref [] - let hists : hists ref - = ref { pat = cbnew 10 E.s; pag = cbnew 10 E.s; sel = cbnew 10 E.s; } - let prevzoom = ref (1.0, 0) - let progress = ref ~-.1.0 - let mpos = ref (-1, -1) - let keystate = ref KSnone - let glinks = ref false - let prevcolumns : (columns * zoom) option ref = ref None - let winw = ref ~-1 - let winh = ref ~-1 - let reprf = ref noreprf - let roamf = ref noroamf - let bzoom = ref false - let lnava : (pageno * linkno) option ref = ref None - let reload : (x * y * float) option ref = ref None - let nav : anchor nav ref = ref { past = []; future = []; } - let tilelru : (tilemapkey * opaque * pixmapsize) Queue.t = Queue.create () - let fontpath = ref E.s - let redirstderr = ref false -end - -let conf = { defconf with keyhashes = copykeyhashes defconf } - -let calcips h = - let d = !S.winh - h in - max conf.interpagespace ((d + 1) / 2) - -let rowyh (c, coverA, coverB) b n = - if c = 1 || (n < coverA || n >= !S.pagecount - coverB) - then - let _, _, vy, (_, _, h, _) = b.(n) in - (vy, h) - else - let n' = n - coverA in - let d = n' mod c in - let s = n - d in - let e = min !S.pagecount (s + c) in - let rec findminmax m miny maxh = - if m = e - then miny, maxh - else - let _, _, y, (_, _, h, _) = b.(m) in - let miny = min miny y in - let maxh = max maxh h in - findminmax (m+1) miny maxh - in - findminmax s max_int 0 - -let page_of_y y = - let ((c, coverA, coverB) as cl), b = - match conf.columns with - | Csplit (_, b) | Csingle b -> (1, 0, 0), b - | Cmulti (c, b) -> c, b - in - if Array.length b = 0 - then -1 - else - let rec bsearch nmin nmax = - if nmin > nmax - then bound nmin 0 (!S.pagecount-1) - else - let n = (nmax + nmin) / 2 in - let vy, h = rowyh cl b n in - let y0, y1 = - if conf.presentation - then - let ips = calcips h in - let y0 = vy - ips in - let y1 = vy + h + ips in - y0, y1 - else ( - if n = 0 - then 0, vy + h + conf.interpagespace - else - let y0 = vy - conf.interpagespace in - y0, y0 + h + conf.interpagespace - ) - in - if y >= y0 && y < y1 - then ( - if c = 1 - then n - else ( - if n > coverA - then - if n < !S.pagecount - coverB - then ((n-coverA)/c)*c + coverA - else n - else n - ) - ) - else ( - if y > y0 - then bsearch (n+1) nmax - else bsearch nmin (n-1) - ) - in - bsearch 0 (!S.pagecount-1) - -let calcheight () = - match conf.columns with - | Cmulti ((_, _, _) as cl, b) -> - if Array.length b > 0 - then - let y, h = rowyh cl b (Array.length b - 1) in - y + h + (if conf.presentation then calcips h else 0) - else 0 - | Csingle b -> - if Array.length b > 0 - then - let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in - y + h + (if conf.presentation then calcips h else 0) - else 0 - | Csplit (_, b) -> - if Array.length b > 0 - then - let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in - y + h - else 0 - -let getpageywh pageno = - let pageno = bound pageno 0 (!S.pagecount-1) in - match conf.columns with - | Csingle b -> - if Array.length b = 0 - then 0, 0, 0 - else - let (_, _, y, (_, w, h, _)) = b.(pageno) in - let y = - if conf.presentation - then y - calcips h - else y - in - y, w, h - | Cmulti (cl, b) -> - if Array.length b = 0 - then 0, 0, 0 - else - let y, h = rowyh cl b pageno in - let (_, _, _, (_, w, _, _)) = b.(pageno) in - let y = - if conf.presentation - then y - calcips h - else y - in - y, w, h - | Csplit (c, b) -> - if Array.length b = 0 - then 0, 0, 0 - else - let n = pageno*c in - let (_, _, y, (_, w, h, _)) = b.(n) in - y, w / c, h - -let getpageyh pageno = - let y,_,h = getpageywh pageno in - y, h - -let getpagedim pageno = - let rec f ppdim l = - match l with - | (n, _, _, _) as pdim :: rest -> - if n >= pageno - then (if n = pageno then pdim else ppdim) - else f pdim rest - | [] -> ppdim - in - f (-1, -1, -1, -1) !S.pdims - -let getpdimno pageno = - let rec f p l = - let np = succ p in - match l with - | (n, _, _, _) :: rest -> - if n >= pageno - then (if n = pageno then np else p) - else f np rest - | [] -> p - in - f ~-1 !S.pdims - -let getpagey pageno = fst (getpageyh pageno) - -let getanchor1 l = - let top = - let coloff = l.pagecol * l.pageh in - float (l.pagey + coloff) /. float l.pageh - in - let dtop = - if l.pagedispy = 0 - then 0.0 - else ( - if conf.presentation - then float l.pagedispy /. float (calcips l.pageh) - else float l.pagedispy /. float conf.interpagespace - ) - in - (l.pageno, top, dtop) - -let getanchor () = - match !S.layout with - | l :: _ -> getanchor1 l - | [] -> - let n = page_of_y !S.y in - if n = -1 - then !S.anchor - else - let y, h = getpageyh n in - let dy = y - !S.y in - let dtop = - if conf.presentation - then - let ips = calcips h in - float (dy + ips) /. float ips - else float dy /. float conf.interpagespace - in - (n, 0.0, dtop) - -type historder = [ `lastvisit | `title | `path | `file ] - -module KeyMap = - Map.Make (struct type t = (int * int) let compare = compare end) - -let unentS s = - let l = String.length s in - let b = Buffer.create l in - Parser.unent b s 0 l; - Buffer.contents b - -let modifier_of_string = function - | "alt" -> Wsi.altmask - | "shift" -> Wsi.shiftmask - | "ctrl" | "control" -> Wsi.ctrlmask - | "meta" -> Wsi.metamask - | _ -> 0 - -let keys_of_string s = - let key_of_string r s = - let elems = Str.full_split r s in - let f n k m = - let g s = - let m1 = modifier_of_string s in - if m1 = 0 - then (Wsi.namekey s, m) - else (k, m lor m1) - in function - | Str.Delim s when n land 1 = 0 -> g s - | Str.Text s -> g s - | Str.Delim _ -> (k, m) - in - let rec loop n k m = function - | [] -> (k, m) - | x :: xs -> - let k, m = f n k m x in - loop (n+1) k m xs - in - loop 0 0 0 elems - in - let elems = Str.split Utils.Re.whitespace s in - List.map (key_of_string (Str.regexp "-")) elems - -let validatehcs v = - let l = String.length v in - if l < 2 - then error "set must contain more than one char, but has %d" l; - let module S = Set.Make (struct type t = char let compare = compare end) in - let rec check s i = - if i < l - then - let e = String.get v i in - if S.mem e s - then error "set has duplicates (at least '%c')" e - else check (S.add e s) (i+1) - in - check (S.singleton (String.get v 0)) 1 - -let config_of c attrs = - let maxv ?(f=int_of_string) u s = max u @@ f s in - let apply c k v = - try - match k with - | "scroll-bar-width" -> { c with scrollbw = maxv 0 v } - | "scroll-handle-height" -> { c with scrollh = maxv 0 v } - | "case-insensitive-search" -> { c with icase = bool_of_string v } - | "preload" -> { c with preload = bool_of_string v } - | "page-bias" -> { c with pagebias = int_of_string v } - | "scroll-step" -> { c with scrollstep = maxv 1 v } - | "horizontal-scroll-step" -> { c with hscrollstep = maxv 1 v } - | "auto-scroll-step" -> { c with autoscrollstep = maxv 0 v } - | "max-height-fit" -> { c with maxhfit = bool_of_string v } - | "highlight-links" -> { c with hlinks = bool_of_string v } - | "under-cursor-info" -> { c with underinfo = bool_of_string v } - | "vertical-margin" -> { c with interpagespace = maxv 0 v } - | "zoom" -> - let zoom = float_of_string v /. 100. in - let zoom = max zoom 0.0 in - { c with zoom = zoom } - | "presentation" -> { c with presentation = bool_of_string v } - | "rotation-angle" -> { c with angle = int_of_string v } - | "width" -> { c with cwinw = maxv 20 v } - | "height" -> { c with cwinh = maxv 20 v } - | "proportional-display" -> - { c with fitmodel = if bool_of_string v - then FitProportional - else FitWidth - } - | "fit-model" -> { c with fitmodel = FMTE.of_string v } - | "pixmap-cache-size" -> - { c with memlimit = maxv ~f:int_of_string_with_suffix 2 v } - | "tex-count" -> { c with texcount = maxv 1 v } - | "slice-height" -> { c with sliceheight = maxv 2 v } - | "thumbnail-width" -> { c with thumbw = maxv 2 v } - | "background-color" -> { c with bgcolor = color_of_string v } - | "paper-color" -> { c with papercolor = rgba_of_string v } - | "scrollbar-color" -> { c with sbarcolor = rgba_of_string v } - | "scrollbar-handle-color" -> { c with sbarhndlcolor = rgba_of_string v } - | "texture-color" -> { c with texturecolor = rgba_of_string v } - | "tile-width" -> { c with tilew = maxv 2 v } - | "tile-height" -> { c with tileh = maxv 2 v } - | "mupdf-store-size" -> - { c with mustoresize = maxv ~f:int_of_string_with_suffix 1024 v } - | "aalevel" -> { c with aalevel = maxv 0 v } - | "trim-margins" -> { c with trimmargins = bool_of_string v } - | "trim-fuzz" -> { c with trimfuzz = irect_of_string v } - | "uri-launcher" -> { c with urilauncher = unentS v } - | "path-launcher" -> { c with pathlauncher = unentS v } - | "color-space" -> { c with colorspace = CSTE.of_string v } - | "invert-colors" -> { c with invert = bool_of_string v } - | "brightness" -> { c with colorscale = float_of_string v } - | "columns" -> - let (n, _, _) as nab = multicolumns_of_string v in - if n < 0 - then { c with columns = Csplit (-n, E.a) } - else { c with columns = Cmulti (nab, E.a) } - | "birds-eye-columns" -> { c with beyecolumns = Some (maxv 2 v) } - | "selection-command" -> { c with selcmd = unentS v } - | "paste-command" -> { c with pastecmd = unentS v } - | "synctex-command" -> { c with stcmd = unentS v } - | "pax-command" -> { c with paxcmd = unentS v } - | "askpass-command" -> { c with passcmd = unentS v } - | "savepath-command" -> { c with savecmd = unentS v } - | "update-cursor" -> { c with updatecurs = bool_of_string v } - | "hint-font-size" -> { c with hfsize = bound (int_of_string v) 5 100 } - | "page-scroll-scale" -> { c with pgscale = float_of_string v } - | "wheel-scrolls-pages" -> { c with wheelbypage = bool_of_string v } - | "horizontal-scrollbar-visible" -> - { c with scrollb = if bool_of_string v - then c.scrollb lor scrollbhv - else c.scrollb land (lnot scrollbhv) - } - | "vertical-scrollbar-visible" -> - { c with scrollb = if bool_of_string v - then c.scrollb lor scrollbvv - else c.scrollb land (lnot scrollbvv) - } - | "remote-in-a-new-instance" -> { c with riani = bool_of_string v } - | "point-and-x" -> - { c with pax = if bool_of_string v then Some 0.0 else None } - | "point-and-x-mark" -> { c with paxmark = MTE.of_string v } - | "scroll-bar-on-the-left" -> { c with leftscroll = bool_of_string v } - | "title" -> { c with title = unentS v } - | "last-visit" -> { c with lastvisit = float_of_string v } - | "edit-annotations-inline" -> { c with annotinline = bool_of_string v } - | "coarse-presentation-positioning" -> - { c with coarseprespos = bool_of_string v } - | "use-document-css" -> { c with usedoccss = bool_of_string v } - | "hint-charset" -> validatehcs v; { c with hcs = v } - | "rlw" -> { c with rlw = int_of_string v } - | "rlh" -> { c with rlh = int_of_string v } - | "rlem" -> { c with rlem = int_of_string v } - | _ -> c - with exn -> - dolog "error processing attribute (`%S' = `%S'): %s" k v @@ exntos exn; - c - in - let rec fold c = function - | [] -> c - | (k, v) :: rest -> - let c = apply c k v in - fold c rest - in - fold { c with keyhashes = copykeyhashes c } attrs - -let fromstring f pos n v d = - try f v - with exn -> - dolog "error processing attribute (%S=%S) at %d\n%s" n v pos @@ exntos exn; - d - -let bookmark_of attrs = - let rec fold title page rely visy = function - | ("title", v) :: rest -> fold v page rely visy rest - | ("page", v) :: rest -> fold title v rely visy rest - | ("rely", v) :: rest -> fold title page v visy rest - | ("visy", v) :: rest -> fold title page rely v rest - | _ :: rest -> fold title page rely visy rest - | [] -> title, page, rely, visy - in - fold "invalid" "0" "0" "0" attrs - -let doc_of attrs = - let rec fold path key page rely pan visy origin dcf = function - | ("path", v) :: rest -> fold v key page rely pan visy origin dcf rest - | ("key", v) :: rest -> fold path v page rely pan visy origin dcf rest - | ("page", v) :: rest -> fold path key v rely pan visy origin dcf rest - | ("rely", v) :: rest -> fold path key page v pan visy origin dcf rest - | ("pan", v) :: rest -> fold path key page rely v visy origin dcf rest - | ("visy", v) :: rest -> fold path key page rely pan v origin dcf rest - | ("origin", v) :: rest -> fold path key page rely pan visy v dcf rest - | ("dcf", v) :: rest -> fold path key page rely pan visy origin v rest - | _ :: rest -> fold path key page rely pan visy origin dcf rest - | [] -> path, key, page, rely, pan, visy, origin, dcf - in - fold E.s E.s "0" "0" "0" "0" E.s E.s attrs - -let map_of attrs = - let rec fold rs ls = function - | ("out", v) :: rest -> fold v ls rest - | ("in", v) :: rest -> fold rs v rest - | _ :: rest -> fold ls rs rest - | [] -> ls, rs - in - fold E.s E.s attrs - -let findkeyhash c name = - try List.assoc name c.keyhashes - with Not_found -> error "invalid mode name `%s'" name - -let get s = - let open Parser in - let h = Hashtbl.create 10 in - let dc = { defconf with angle = defconf.angle } in - let rec toplevel v t spos _ = - match t with - | Vdata | Vcdata | Vend -> v - | Vopen ("llppconfig", _, closed) -> - if closed - then v - else { v with f = llppconfig } - | Vopen _ -> parse_error "unexpected subelement at top level" s spos - | Vclose _ -> parse_error "unexpected close at top level" s spos - - and llppconfig v t spos _ = - match t with - | Vdata | Vcdata -> v - | Vend -> parse_error "unexpected end of input in llppconfig" s spos - | Vopen ("defaults", attrs, closed) -> - let c = config_of dc attrs in - setconf dc c; - if closed - then v - else { v with f = defaults } - - | Vopen ("ui-font", attrs, closed) -> - let rec getsize size = function - | [] -> size - | ("size", v) :: rest -> - let size = - fromstring int_of_string spos "size" v fstate.fontsize in - getsize size rest - | l -> getsize size l - in - fstate.fontsize <- getsize fstate.fontsize attrs; - if closed - then v - else { v with f = uifont (Buffer.create 10) } - - | Vopen ("doc", attrs, closed) -> - let pathent, key, spage, srely, span, svisy, origin, dcf - = doc_of attrs in - let path = unentS pathent - and origin = unentS origin - and pageno = fromstring int_of_string spos "page" spage 0 - and rely = fromstring float_of_string spos "rely" srely 0.0 - and pan = fromstring int_of_string spos "pan" span 0 - and visy = fromstring float_of_string spos "visy" svisy 0.0 in - let c = config_of dc attrs in - c.key <- key; - c.dcf <- unentS dcf; - let anchor = (pageno, rely, visy) in - if closed - then (Hashtbl.add h path (c, [], pan, anchor, origin); v) - else { v with f = doc path origin pan anchor c [] } - - | Vopen _ -> parse_error "unexpected subelement in llppconfig" s spos - | Vclose "llppconfig" -> { v with f = toplevel } - | Vclose _ -> parse_error "unexpected close in llppconfig" s spos - - and defaults v t spos _ = - match t with - | Vdata | Vcdata -> v - | Vend -> parse_error "unexpected end of input in defaults" s spos - | Vopen ("keymap", attrs, closed) -> - let modename = - try List.assoc "mode" attrs - with Not_found -> "global" in - if closed - then v - else - let ret keymap = - let h = findkeyhash dc modename in - KeyMap.iter (Hashtbl.replace h) keymap; - defaults - in - { v with f = pkeymap ret KeyMap.empty } - - | Vopen (_, _, _) -> parse_error "unexpected subelement in defaults" s spos - - | Vclose "defaults" -> - { v with f = llppconfig } - - | Vclose _ -> parse_error "unexpected close in defaults" s spos - - and uifont b v t spos epos = - match t with - | Vdata | Vcdata -> - Buffer.add_substring b s spos (epos - spos); - v - | Vopen (_, _, _) -> parse_error "unexpected subelement in ui-font" s spos - | Vclose "ui-font" -> - if emptystr !S.fontpath - then S.fontpath := Buffer.contents b; - { v with f = llppconfig } - | Vclose _ -> parse_error "unexpected close in ui-font" s spos - | Vend -> parse_error "unexpected end of input in ui-font" s spos - - and doc path origin pan anchor c bookmarks v t spos _ = - match t with - | Vdata | Vcdata -> v - | Vend -> parse_error "unexpected end of input in doc" s spos - | Vopen ("bookmarks", _, closed) -> - if closed - then v - else { v with f = pbookmarks path origin pan anchor c bookmarks } - - | Vopen ("keymap", attrs, closed) -> - let modename = - try List.assoc "mode" attrs - with Not_found -> "global" - in - if closed - then v - else - let ret keymap = - let h = findkeyhash c modename in - KeyMap.iter (Hashtbl.replace h) keymap; - doc path origin pan anchor c bookmarks - in - { v with f = pkeymap ret KeyMap.empty } - - | Vopen ("css", [], false) -> - { v with f = pcss path origin pan anchor c bookmarks } - - | Vopen (_, _, _) -> - parse_error "unexpected subelement in doc" s spos - - | Vclose "doc" -> - Hashtbl.add h path (c, List.rev bookmarks, pan, anchor, origin); - { v with f = llppconfig } - - | Vclose _ -> parse_error "unexpected close in doc" s spos - - and pcss path origin pan anchor c bookmarks v t spos epos = - match t with - | Vdata | Vcdata -> - let b = Buffer.create 10 in - Buffer.add_substring b s spos (epos - spos); - { v with f = pcss path origin pan anchor - { c with css = Buffer.contents b } - bookmarks } - | Vend -> parse_error "unexpected end of input in css" s spos - | Vopen _ -> parse_error "unexpected subelement in css" s spos - | Vclose "css" -> { v with f = doc path origin pan anchor c bookmarks } - | Vclose _ -> parse_error "unexpected close in css" s spos - - and pkeymap ret keymap v t spos _ = - match t with - | Vdata | Vcdata -> v - | Vend -> parse_error "unexpected end of input in keymap" s spos - | Vopen ("map", attrs, closed) -> - let r, l = map_of attrs in - let kss = fromstring keys_of_string spos "in" r [] in - let lss = fromstring keys_of_string spos "out" l [] in - let keymap = - match kss with - | [] -> keymap - | ks :: [] -> KeyMap.add ks (KMinsrl lss) keymap - | ks :: rest -> KeyMap.add ks (KMmulti (rest, lss)) keymap - in - if closed - then { v with f = pkeymap ret keymap } - else - let f () = v in - { v with f = skip "map" f } - - | Vopen _ -> parse_error "unexpected subelement in keymap" s spos - | Vclose "keymap" -> - { v with f = ret keymap } - | Vclose _ -> parse_error "unexpected close in keymap" s spos - - and pbookmarks path origin pan anchor c bookmarks v t spos _ = - match t with - | Vdata | Vcdata -> v - | Vend -> parse_error "unexpected end of input in bookmarks" s spos - | Vopen ("item", attrs, closed) -> - let titleent, spage, srely, svisy = bookmark_of attrs in - let page = fromstring int_of_string spos "page" spage 0 - and rely = fromstring float_of_string spos "rely" srely 0.0 - and visy = fromstring float_of_string spos "visy" svisy 0.0 in - let bookmarks = - (unentS titleent, 0, Oanchor (page, rely, visy)) :: bookmarks - in - if closed - then { v with f = pbookmarks path origin pan anchor c bookmarks } - else - let f () = v in - { v with f = skip "item" f } - - | Vopen _ -> parse_error "unexpected subelement in bookmarks" s spos - | Vclose "bookmarks" -> - { v with f = doc path origin pan anchor c bookmarks } - | Vclose _ -> parse_error "unexpected close in bookmarks" s spos - - and skip tag f v t spos _ = - match t with - | Vdata | Vcdata -> v - | Vend -> parse_error ("unexpected end of input in skipped " ^ tag) s spos - | Vopen (tag', _, closed) -> - if closed - then v - else - let f' () = { v with f = skip tag f } in - { v with f = skip tag' f' } - | Vclose ctag -> - if tag = ctag - then f () - else parse_error ("unexpected close in skipped " ^ tag) s spos - in - parse { f = toplevel; accu = () } s; - h, dc - -let do_load f contents = - try f contents - with - | Parser.Parse_error (msg, s, pos) -> - let subs = Parser.subs s pos in - Utils.error "parse error: %s: at %d [..%S..]" msg pos subs - - | exn -> Utils.error "parse error: %s" @@ exntos exn - -let load2 f default = - match filecontents !S.confpath with - | contents -> f @@ do_load get contents - | exception Unix.Unix_error (Unix.ENOENT, "open", _) -> - f (Hashtbl.create 0, defconf) - | exception exn -> - dolog "error loading configuration from `%S': %s" - !S.confpath @@ exntos exn; - default - -let load1 f = load2 f false - -let load openlast = - let f (h, dc) = - if openlast - then ( - let path, _ = - Hashtbl.fold - (fun path (conf, _, _, _, _) ((_, besttime) as best) -> - if conf.lastvisit > besttime - then (path, conf.lastvisit) - else best) - h - (!S.path, -.infinity) - in - S.path := path; - ); - let pc, pb, px, pa, po = - let def = dc, [], 0, E.j, !S.origin in - if emptystr !S.path - then def - else - let absname = abspath !S.path in - match Hashtbl.find h absname with - | (c,b,x,a,_) -> (c,b,x,a,!S.origin) - | exception Not_found -> - let exception E of (conf * outline list * int * anchor * string) in - let key = try Digest.file absname |> Digest.to_hex with _ -> E.s in - match ( - if nonemptystr key - then - Hashtbl.iter (fun p ((c, _, _, _, _) as v) -> - if c.key = key - then ( - dolog "will use %s's settings due to matching keys" p; - raise (E v) - ) - ) h - ) - with - | _ -> def - | exception E v -> v - in - setconf defconf dc; - setconf conf pc; - S.bookmarks := pb; - S.x := px; - S.origin := po; - S.anchor := pa; - true - in - load1 f - -let gethist () = - let f (h, _) = - Hashtbl.fold (fun path (pc, pb, px, pa, po) accu -> - (path, pc, pb, px, pa, po) :: accu) - h []; - in - load2 f [] - -let add_attrs bb always dc c time = - let o' fmt s = - Buffer.add_string bb "\n "; - Printf.bprintf bb fmt s - in - let o c fmt s = if c then o' fmt s else ignore in - let ob s a b = o (always || a != b) "%s='%b'" s a - and op s a b = o (always || a <> b) "%s='%b'" s (a != None) - and oi s a b = o (always || a != b) "%s='%d'" s a - and oI s a b = o (always || a != b) "%s='%s'" s (string_with_suffix_of_int a) - and oz s a b = o (always || a <> b) "%s='%g'" s (a*.100.) - and oF s a b = o (always || a <> b) "%s='%f'" s a - and oL s a b = o (always || a <> b) "%s='%Ld'" s a - and oc s a b = o (always || a <> b) "%s='%s'" s (color_to_string a) - and oA s a b = o (always || a <> b) "%s='%s'" s (rgba_to_string a) - and oC s a b = o (always || a <> b) "%s='%s'" s (CSTE.to_string a) - and oR s a b = o (always || a <> b) "%s='%s'" s (irect_to_string a) - and oFm s a b = o (always || a <> b) "%s='%s'" s (FMTE.to_string a) - and oSv s a b m = - o (always || a land m <> b land m) "%s='%b'" s (a land m != 0) - and oPm s a b = o (always || a <> b) "%s='%s'" s (MTE.to_string a) - and os s a b = - o (always || a <> b) "%s='%s'" s @@ Parser.enent a 0 (String.length a) - and oco s a b = - if always || a <> b - then - match a with - | Cmulti ((n, a, b), _) when n > 1 -> o' "%s='%d,%d,%d'" s n a b - | Csplit (n, _) when n > 1 -> o' "%s='%d'" s ~-n - | Cmulti _ | Csplit _ | Csingle _ -> () - and obeco s a b = - if always || a <> b - then - match a with - | Some c when c > 1 -> o' "%s='%d'" s c - | _ -> () - in - oi "width" c.cwinw dc.cwinw; - oi "height" c.cwinh dc.cwinh; - oi "scroll-bar-width" c.scrollbw dc.scrollbw; - oi "scroll-handle-height" c.scrollh dc.scrollh; - oSv "horizontal-scrollbar-visible" c.scrollb dc.scrollb scrollbhv; - oSv "vertical-scrollbar-visible" c.scrollb dc.scrollb scrollbvv; - ob "case-insensitive-search" c.icase dc.icase; - ob "preload" c.preload dc.preload; - oi "page-bias" c.pagebias dc.pagebias; - oi "scroll-step" c.scrollstep dc.scrollstep; - oi "auto-scroll-step" c.autoscrollstep dc.autoscrollstep; - ob "max-height-fit" c.maxhfit dc.maxhfit; - ob "highlight-links" c.hlinks dc.hlinks; - ob "under-cursor-info" c.underinfo dc.underinfo; - oi "vertical-margin" c.interpagespace dc.interpagespace; - oz "zoom" c.zoom dc.zoom; - ob "presentation" c.presentation dc.presentation; - oi "rotation-angle" c.angle dc.angle; - oFm "fit-model" c.fitmodel dc.fitmodel; - oI "pixmap-cache-size" c.memlimit dc.memlimit; - oi "tex-count" c.texcount dc.texcount; - oi "slice-height" c.sliceheight dc.sliceheight; - oi "thumbnail-width" c.thumbw dc.thumbw; - oc "background-color" c.bgcolor dc.bgcolor; - oA "paper-color" c.papercolor dc.papercolor; - oA "scrollbar-color" c.sbarcolor dc.sbarcolor; - oA "scrollbar-handle-color" c.sbarhndlcolor dc.sbarhndlcolor; - oA "texture-color" c.texturecolor dc.texturecolor; - oi "tile-width" c.tilew dc.tilew; - oi "tile-height" c.tileh dc.tileh; - oI "mupdf-store-size" c.mustoresize dc.mustoresize; - oi "aalevel" c.aalevel dc.aalevel; - ob "trim-margins" c.trimmargins dc.trimmargins; - oR "trim-fuzz" c.trimfuzz dc.trimfuzz; - os "uri-launcher" c.urilauncher dc.urilauncher; - os "path-launcher" c.pathlauncher dc.pathlauncher; - oC "color-space" c.colorspace dc.colorspace; - ob "invert-colors" c.invert dc.invert; - oF "brightness" c.colorscale dc.colorscale; - oco "columns" c.columns dc.columns; - obeco "birds-eye-columns" c.beyecolumns dc.beyecolumns; - os "selection-command" c.selcmd dc.selcmd; - os "paste-command" c.pastecmd dc.pastecmd; - os "synctex-command" c.stcmd dc.stcmd; - os "pax-command" c.paxcmd dc.paxcmd; - os "askpass-command" c.passcmd dc.passcmd; - os "savepath-command" c.savecmd dc.savecmd; - ob "update-cursor" c.updatecurs dc.updatecurs; - oi "hint-font-size" c.hfsize dc.hfsize; - oi "horizontal-scroll-step" c.hscrollstep dc.hscrollstep; - oF "page-scroll-scale" c.pgscale dc.pgscale; - ob "wheel-scrolls-pages" c.wheelbypage dc.wheelbypage; - ob "remote-in-a-new-instance" c.riani dc.riani; - op "point-and-x" c.pax dc.pax; - oPm "point-and-x-mark" c.paxmark dc.paxmark; - ob "scroll-bar-on-the-left" c.leftscroll dc.leftscroll; - if not always - then os "title" c.title dc.title; - oL "last-visit" (Int64.of_float time) 0L; - ob "edit-annotations-inline" c.annotinline dc.annotinline; - ob "coarse-presentation-positioning" c.coarseprespos dc.coarseprespos; - ob "use-document-css" c.usedoccss dc.usedoccss; - os "dcf" c.dcf dc.dcf; - os "hint-charset" c.hcs dc.hcs; - oi "rlw" c.rlw dc.rlw; - oi "rlh" c.rlh dc.rlh; - oi "rlem" c.rlem dc.rlem - -let keymapsbuf always dc c = - let open Buffer in - let bb = create 16 in - let rec loop = function - | [] -> () - | (modename, h) :: rest -> - let dh = findkeyhash dc modename in - if always || h <> dh - then ( - if Hashtbl.length h > 0 - then ( - if length bb > 0 then add_char bb '\n'; - Printf.bprintf bb "\n" modename; - Hashtbl.iter (fun i o -> - if always || match Hashtbl.find dh i - with | dO -> dO <> o | exception Not_found -> false - then - let addkm (k, m) = - if Wsi.withctrl m then add_string bb "ctrl-"; - if Wsi.withalt m then add_string bb "alt-"; - if Wsi.withshift m then add_string bb "shift-"; - if Wsi.withmeta m then add_string bb "meta-"; - add_string bb (Wsi.keyname k); - in - let addkms l = - let rec loop = function - | [] -> () - | km :: [] -> addkm km - | km :: rest -> addkm km; add_char bb ' '; loop rest - in - loop l - in - add_string bb "\n" - - | KMinsrl kms -> - add_string bb "' out='"; addkms kms; add_string bb "'/>\n" - - | KMmulti (ins, kms) -> - add_char bb ' '; addkms ins; add_string bb "' out='"; - addkms kms; add_string bb "'/>\n" - ) h; - add_string bb ""; - ); - ); - loop rest - in - loop c.keyhashes; - bb - -let keystostrlist c = - let rec loop accu = function - | [] -> accu - | (modename, h) :: rest -> - let accu = - if Hashtbl.length h > 0 - then ( - let accu = Printf.sprintf "\xc2\xb7Keys for %s" modename :: accu in - Hashtbl.fold (fun i o a -> - let bb = Buffer.create 10 in - let addkm (k, m) = - if Wsi.withctrl m then Buffer.add_string bb "ctrl-"; - if Wsi.withalt m then Buffer.add_string bb "alt-"; - if Wsi.withshift m then Buffer.add_string bb "shift-"; - if Wsi.withmeta m then Buffer.add_string bb "meta-"; - Buffer.add_string bb (Wsi.keyname k); - in - let addkms l = - let rec loop = function - | [] -> () - | km :: [] -> addkm km - | km :: rest -> - addkm km; Buffer.add_char bb ' '; - loop rest - in - loop l - in - addkm i; - Buffer.add_char bb '\t'; - begin match o with - | KMinsrt km -> addkm km - | KMinsrl kms -> addkms kms - | KMmulti (ins, kms) -> - Buffer.add_char bb ' '; - addkms ins; - Buffer.add_string bb "\t"; - addkms kms - end; - Buffer.contents bb :: a - ) h accu - ) - else accu - in - loop accu rest - in - loop [] c.keyhashes - -let save1 bb leavebirdseye x h dc = - let uifontsize = fstate.fontsize in - Buffer.add_string bb "\n"; - if nonemptystr !S.fontpath - then ( - Printf.bprintf bb "\n" - uifontsize !S.fontpath - ) - else ( - if uifontsize <> 14 - then Printf.bprintf bb "\n" uifontsize - ); - - Buffer.add_string bb " 0 - then ( - Buffer.add_string bb ">\n"; - Buffer.add_buffer bb kb; - Buffer.add_string bb "\n\n"; - ) - else Buffer.add_string bb "/>\n"; - - let adddoc path pan anchor c bookmarks time origin = - if not (bookmarks == [] && c = dc && anchor = E.j) - then ( - Printf.bprintf bb " E.j - then ( - let n, rely, visy = anchor in - Printf.bprintf bb "\n page='%d'" n; - - if rely > 1e-6 - then Printf.bprintf bb " rely='%f'" rely; - - if abs_float visy > 1e-6 - then Printf.bprintf bb " visy='%f'" visy; - ); - - if pan != 0 - then Printf.bprintf bb " pan='%d'" pan; - - add_attrs bb false dc c time; - if nonemptystr c.css - then Printf.bprintf bb ">\n " c.css; - let kb = keymapsbuf false dc c in - - begin match bookmarks with - | [] -> - if Buffer.length kb > 0 - then ( - Buffer.add_string bb ">\n"; - Buffer.add_buffer bb kb; - Buffer.add_string bb "\n\n"; - ) - else ( - if nonemptystr c.css - then Buffer.add_string bb "\n\n" - else Buffer.add_string bb "/>\n" - ) - | _ -> - Buffer.add_string bb ">\n\n"; - List.iter (fun (title, _, kind) -> - begin match kind with - | Oanchor (page, rely, visy) -> - Printf.bprintf bb - " 1e-6 - then Printf.bprintf bb " rely='%f'" rely; - if abs_float visy > 1e-6 - then Printf.bprintf bb " visy='%f'" visy; - - | Ohistory _ | Onone | Ouri _ | Oremote _ - | Oremotedest _ | Olaunch _ -> error "unexpected link in bookmarks" - end; - Buffer.add_string bb "/>\n"; - ) bookmarks; - Buffer.add_string bb ""; - if Buffer.length kb > 0 - then ( - Buffer.add_string bb "\n"; - Buffer.add_buffer bb kb; - ); - Buffer.add_string bb "\n\n" - end - ) - in - - let pan, conf = - match !S.mode with - | Birdseye (c, pan, _, _, _) -> - let beyecolumns = - match conf.columns with - | Cmulti ((c, _, _), _) -> Some c - | Csingle _ - | Csplit _ -> None - and columns = - match c.columns with - | Cmulti (c, _) -> Cmulti (c, E.a) - | Csingle _ -> Csingle E.a - | Csplit _ -> failwith "quit from bird's eye while split" - in - pan, { c with beyecolumns = beyecolumns; columns = columns } - | Textentry _ - | View - | LinkNav _ -> x, conf - in - let docpath = if nonemptystr !S.path then abspath !S.path else E.s in - if nonemptystr docpath - then ( - adddoc docpath pan (getanchor ()) - ( - begin match !S.mode with - | Birdseye beye -> leavebirdseye beye true - | Textentry _ - | View - | LinkNav _ -> () - end; - { conf with - autoscrollstep = (match !S.autoscroll with - | Some step -> step - | None -> conf.autoscrollstep) - ; key = (if emptystr conf.key - then (try Digest.file docpath |> Digest.to_hex with _ -> E.s) - else conf.key) - } - ) - !S.bookmarks - (now ()) - !S.origin - ); - Hashtbl.iter (fun path (c, bookmarks, x, anchor, origin) -> - if docpath <> abspath path - then adddoc path x anchor c bookmarks c.lastvisit origin - ) h; - Buffer.add_string bb "\n"; - true - -let save leavebirdseye = - let relx = float !S.x /. float !S.winw in - let w, h, x = - let cx w = truncate (relx *. float w) in - List.fold_left - (fun (w, h, x) ws -> - match ws with - | Wsi.Fullscreen -> (conf.cwinw, conf.cwinh, cx conf.cwinw) - | Wsi.MaxVert -> (w, conf.cwinh, x) - | Wsi.MaxHorz -> (conf.cwinw, h, cx conf.cwinw) - ) - (!S.winw, !S.winh, !S.x) !S.winstate - in - conf.cwinw <- w; - conf.cwinh <- h; - let bb = Buffer.create 32768 in - let save2 (h, dc) = save1 bb leavebirdseye x h dc in - if load1 save2 && Buffer.length bb > 0 - then - try - let tmp = !S.confpath ^ ".tmp" in - let oc = open_out_bin tmp in - Buffer.output_buffer oc bb; - close_out oc; - Unix.rename tmp !S.confpath; - with exn -> dolog "error saving configuration: %s" @@ exntos exn - -let gc () = - let href = ref @@ Hashtbl.create 0 in - let cref = ref defconf in - let push (h, dc) = - let f path v = - if Sys.file_exists path then Some v else (dolog "removing %S" path; None) - in - Hashtbl.filter_map_inplace f h; - href := h; - cref := dc; - true - in - ignore (load1 push); - let bb = Buffer.create 32768 in - let save2 (_h, dc) = save1 bb (fun _ _ -> ()) 0 !href dc in - if load1 save2 && Buffer.length bb > 0 - then ( - try - let tmp = !S.confpath ^ ".tmp" in - let oc = open_out_bin tmp in - Buffer.output_buffer oc bb; - close_out oc; - Unix.rename tmp !S.confpath; - with exn -> dolog "error saving configuration: %s" @@ exntos exn - ) - -let logcurrently = function - | Idle -> dolog "Idle" - | Loading (l, gen) -> dolog "Loading %d gen=%d curgen=%d" l.pageno gen !S.gen - | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) -> - dolog "Tiling %d[%d,%d] page=%s cs=%s angle=%d" - l.pageno col row (Opaque.to_string pageopaque) - (CSTE.to_string colorspace) angle; - dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)" - angle gen conf.angle !S.gen - tilew tileh - conf.tilew conf.tileh - | Outlining _ -> dolog "outlining" diff --git a/cutils.c b/cutils.c deleted file mode 100644 index 2ba510a..0000000 --- a/cutils.c +++ /dev/null @@ -1,66 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include - -#include "cutils.h" - -_Noreturn void GCC_FMT_ATTR (3, 4) err (int exitcode, int errno_val, - const char *fmt, ...) -{ - va_list ap; - - va_start (ap, fmt); - vfprintf (stdout, fmt, ap); - va_end (ap); - fprintf (stdout, ": %s\n", strerror (errno_val)); - fflush (stdout); - _exit (exitcode); -} - -_Noreturn void GCC_FMT_ATTR (2, 3) errx (int exitcode, const char *fmt, ...) -{ - va_list ap; - - va_start (ap, fmt); - vfprintf (stdout, fmt, ap); - va_end (ap); - fputc ('\n', stdout); - fflush (stdout); - _exit (exitcode); -} - -void *parse_pointer (const char *cap, const char *s) -{ - void *ptr; - int ret = sscanf (s, "%" SCNxPTR, (uintptr_t *) &ptr); - if (ret != 1) { - errx (1, "%s: cannot parse pointer in `%s' (ret=%d)", cap, s, ret); - } - return ptr; -} - -double now (void) -{ - struct timeval tv; - gettimeofday (&tv, NULL); /* gettimeofday shall always return zero */ - return tv.tv_sec + tv.tv_usec*1e-6; -} - -void fmt_linkn (char *s, const char *c, unsigned int l, int n) -{ - div_t d; - int sl = 0, nn = n; - - do { d = div (n, l); sl++; n = d.quot; } while (d.quot); - for (int i = 0, n = nn; i < sl; ++i) { - d = div (n, l); - s[sl-1-i] = c[d.rem]; - n = d.quot; - } - s[sl] = 0; -} diff --git a/cutils.h b/cutils.h deleted file mode 100644 index f7f49e7..0000000 --- a/cutils.h +++ /dev/null @@ -1,24 +0,0 @@ -#ifndef CUTILS_H -#define CUTILS_H - -#if defined __GNUC__ -#define UNUSED_ATTR __attribute__ ((unused)) -#if !defined __clang__ -#define NO_OPTIMIZE_ATTR __attribute__ ((optimize ("O0"))) -#else -#define NO_OPTIMIZE_ATTR __attribute__ ((optnone)) -#endif -#define GCC_FMT_ATTR(a, b) __attribute__ ((format (printf, a, b))) -#else -#error Stringent C compiler requirements not satisfied -#endif - -extern _Noreturn void GCC_FMT_ATTR (3, 4) - err (int errno_val, int exitcode, const char *fmt, ...); -extern _Noreturn void GCC_FMT_ATTR (2, 3) - errx (int exitcode, const char *fmt, ...); -extern void *parse_pointer (const char *cap, const char *s); -extern double now (void); -extern void fmt_linkn (char *s, const char *c, unsigned int l, int n); - -#endif diff --git a/ffi.ml b/ffi.ml deleted file mode 100644 index 6b0c568..0000000 --- a/ffi.ml +++ /dev/null @@ -1,63 +0,0 @@ -open Config - -type initparams = (angle * fitmodel * trimparams * texcount * sliceheight * - memsize * colorspace * fontpath * redirstderr) -and xoff = int and yoff = int and noff = int -and li = (noff * string * hintfontsize * hintchars) -and hlmask = int and hintchars = string and hintfontsize = int - -external init : Unix.file_descr -> initparams -> Unix.file_descr = "ml_init" -external seltext : opaque -> (int * int * int * int) -> unit = "ml_seltext" -external hassel : opaque -> bool = "ml_hassel" -external getpdimrect : int -> float array = "ml_getpdimrect" -external whatsunder : opaque -> x -> y -> under = "ml_whatsunder" -external markunder : opaque -> x -> y -> mark -> bool = "ml_markunder" -external clearmark : opaque -> unit = "ml_clearmark" -external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height" -external getmaxw : unit -> float = "ml_getmaxw" -external postprocess : opaque -> hlmask -> xoff -> yoff -> li -> noff - = "ml_postprocess" -external setdcf : string -> unit = "ml_setdcf" -external pagebbox : opaque -> irect = "ml_getpagebox" -external setaalevel : int -> unit = "ml_setaalevel" -external setpapercolor : rgba -> unit = "ml_setpapercolor" -external realloctexts : int -> bool = "ml_realloctexts" -external findlink : opaque -> linkdir -> link = "ml_findlink" -external getlink : opaque -> int -> under = "ml_getlink" -external getlinkn : opaque -> string -> string -> int -> int = "ml_getlinkn" -external getlinkrect : opaque -> int -> irect = "ml_getlinkrect" -external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links" -external unproject : opaque -> int -> int -> (int * int) option - = "ml_unproject" -external project : opaque -> int -> int -> float -> float -> (float * float) - = "ml_project" -external drawtile : tileparams -> opaque -> unit = "ml_drawtile" -external rectofblock : opaque -> int -> int -> float array option - = "ml_rectofblock" -external begintiles : unit -> unit = "ml_begintiles" -external endtiles : unit -> unit = "ml_endtiles" -external addannot : opaque -> int -> int -> string -> unit = "ml_addannot" -external modannot : opaque -> slinkindex -> string -> unit = "ml_modannot" -external delannot : opaque -> slinkindex -> unit = "ml_delannot" -external hasunsavedchanges : unit -> bool = "ml_hasunsavedchanges" -external savedoc : string -> unit = "ml_savedoc" -external gettextannot : opaque -> slinkindex -> string = "ml_gettextannot" -external getfileannot : opaque -> slinkindex -> string = "ml_getfileannot" -external savefileannot : opaque -> slinkindex -> string -> unit - = "ml_savefileannot" -external wcmd : Unix.file_descr -> bytes -> int -> unit = "ml_wcmd" -external rcmd : Unix.file_descr -> string = "ml_rcmd" -external uritolocation : string -> (pageno * float * float) = "ml_uritolocation" -external isexternallink : string -> bool = "ml_isexternallink" - -(* copysel _will_ close the supplied descriptor *) -external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel" - -external drawstr : int -> int -> int -> string -> float = "ml_draw_string" - -external fz_version : unit -> string = "ml_fz_version" -external llpp_version : unit -> string = "ml_llpp_version" - -external measurestr : int -> string -> float = "ml_measure_string" -external toutf8 : int -> string = "ml_keysymtoutf8" -external mbtoutf8 : string -> string = "ml_mbtoutf8" diff --git a/genconfstruct.sh b/genconfstruct.sh deleted file mode 100644 index 683caeb..0000000 --- a/genconfstruct.sh +++ /dev/null @@ -1,141 +0,0 @@ -#!/bin/sh -set -eu - -cat<&2|}' -s passcmd Utils.E.s -s savecmd Utils.E.s -b updatecurs true -K keyhashes '(string * keyhash) list' \ -'(let mk n = (n, Hashtbl.create 1) in - [ mk "global"; mk "info" ; mk "help"; mk "outline"; mk "listview" - ; mk "birdseye"; mk "textentry"; mk "links"; mk "view" ])' -i hfsize 'Wsi.fontsizescale 12' -f pgscale 1. -b wheelbypage false -s stcmd "{|echo SyncTex|}" -b riani false -g paxmark mark MarkWord -b leftscroll false -s title Utils.E.s -f lastvisit 0.0 -b annotinline true -b coarseprespos false -g css css Utils.E.s -b usedoccss true -s key Utils.E.s -P pax -g dcf dcf Utils.E.s -s hcs "{|aoeuidhtns|}" -i rlw 420 -i rlh 595 -i rlem 11 - -cat < k, Hashtbl.copy v) c.keyhashes -let defconf = {$init} -let setconf dst src = $assi; -EOF diff --git a/glfont.c b/glfont.c deleted file mode 100644 index b46a22a..0000000 --- a/glfont.c +++ /dev/null @@ -1,390 +0,0 @@ -/* This is a slightly modified - https://github.com/ccxvii/snippets/blob/master/glfont.c by Tor Andersson -*/ -/* - * A very simple font cache and rasterizer that uses freetype - * to draw fonts from a single OpenGL texture. The code uses - * a linear-probe hashtable, and writes new glyphs into - * the texture using glTexSubImage2D. When the texture fills - * up, or the hash table gets too crowded, everything is wiped. - * - * This is designed to be used for horizontal text only, - * and draws unhinted text with subpixel accurate metrics - * and kerning. As such, you should always call the drawing - * function with an identity transform that maps units - * to pixels accurately. - * - * If you wish to use it to draw arbitrarily transformed - * text, change the min and mag filters to GL_LINEAR and - * add a pixel of padding between glyphs and rows, and - * make sure to clear the texture when wiping the cache. - */ - -#include FT_ADVANCES_H -typedef int Rune; /* 32 bits */ - -#define PADDING 1 /* set to 0 to save some space but disallow arbitrary transforms */ - -#define MAXGLYPHS 4093 /* prime number for hash table goodness */ -#define CACHESIZE 256 -#define XPRECISION 4 -#define YPRECISION 1 - -struct key -{ - FT_Face face; - short size; - short gid; - short subx; - short suby; -}; - -struct glyph -{ - signed char lsb, top, w, h; - short s, t; - float advance; -}; - -struct table -{ - struct key key; - struct glyph glyph; -}; - -static FT_Library g_freetype_lib = NULL; -static struct table g_table[MAXGLYPHS]; -static int g_table_load = 0; -static unsigned int g_cache_tex = 0; -static int g_cache_w = CACHESIZE; -static int g_cache_h = CACHESIZE; -static int g_cache_row_y = 0; -static int g_cache_row_x = 0; -static int g_cache_row_h = 0; -static int g_use_kern = 0; - -static void init_font_cache(void) -{ - int code; - - code = FT_Init_FreeType(&g_freetype_lib); - if (code) - errx(1, "cannot initialize freetype"); - - glGenTextures(1, &g_cache_tex); - glBindTexture(GL_TEXTURE_2D, g_cache_tex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); - glTexImage2D(GL_TEXTURE_2D, 0, GL_ALPHA, g_cache_w, g_cache_h, 0, GL_ALPHA, GL_UNSIGNED_BYTE, NULL); -} - -static void clear_font_cache(void) -{ -#if PADDING > 0 - unsigned char *zero = calloc(g_cache_w, g_cache_h); - if (!zero) - err(1, errno, "malloc zero (%u bytes failed)", g_cache_w * g_cache_h); - glBindTexture(GL_TEXTURE_2D, g_cache_tex); - glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, g_cache_w, g_cache_h, GL_ALPHA, GL_UNSIGNED_BYTE, zero); - free(zero); -#endif - - memset(g_table, 0, sizeof(g_table)); - g_table_load = 0; - - g_cache_row_y = PADDING; - g_cache_row_x = PADDING; - g_cache_row_h = 0; -} - -static void *filecontents (const char *path, int *len) -{ - int ret, fd; - void *res; - struct stat st; - ssize_t nread; - - ret = stat(path, &st); - if (ret) err(1, errno, "failed to stat `%s'", path); - if (st.st_size > INT_MAX) errx(1, "font `%s' is too big", path); - res = malloc(st.st_size); - if (!res) - err(1, errno, "failed to allocate %llu bytes for `%s'", - st.st_size+0ull, path); - - fd = open(path, O_RDONLY); - if (fd < 0) err(1, errno, "failed to open `%s'", path); - - nread = read(fd, res, st.st_size); - if (nread - st.st_size) - err(1, errno, "read %llu failed, ret=%zd", - st.st_size+0llu, nread); - - *len = (int) st.st_size; - return res; -} - -static FT_Face load_font(const char *fontname) -{ - FT_Face face; - int code, len; - void *base; - - if (g_freetype_lib == NULL) - { - init_font_cache(); - clear_font_cache(); - } - - base = filecontents(fontname, &len); - code = FT_New_Memory_Face(g_freetype_lib, base, len, 0, &face); - if (code) - { - errx(1, "FT_New_Memory_Face for `%s' failed: %d", - fontname, code); - } - - FT_Select_Charmap(face, ft_encoding_unicode); - return face; -} - -static FT_Face load_builtin_font(const void *base, int len) -{ - FT_Face face; - int code; - - if (g_freetype_lib == NULL) - { - init_font_cache(); - clear_font_cache(); - } - - code = FT_New_Memory_Face(g_freetype_lib, base, len, 0, &face); - if (code) - { - errx (1, "failed to load builtin font: %d\n", code); - return NULL; - } - - FT_Select_Charmap(face, ft_encoding_unicode); - return face; -} - -static void UNUSED_ATTR free_font(FT_Face face) -{ - clear_font_cache(); - FT_Done_Face(face); -} - -static unsigned int hashfunc(struct key *key) -{ - unsigned char *buf = (unsigned char *)key; - unsigned int len = sizeof(struct key); - unsigned int h = 0; - while (len--) - h = *buf++ + (h << 6) + (h << 16) - h; - return h; -} - -static unsigned int lookup_table(struct key *key) -{ - unsigned int pos = hashfunc(key) % MAXGLYPHS; - while (1) - { - if (!g_table[pos].key.face) /* empty slot */ - return pos; - if (!memcmp(key, &g_table[pos].key, sizeof(struct key))) /* matching slot */ - return pos; - pos = (pos + 1) % MAXGLYPHS; - } -} - -static struct glyph * lookup_glyph(FT_Face face, int size, int gid, int subx, int suby) -{ - FT_Vector subv; - struct key key; - unsigned int pos; - int code; - int w, h; - - /* - * Look it up in the table - */ - - key.face = face; - key.size = size; - key.gid = gid; - key.subx = subx; - key.suby = suby; - - pos = lookup_table(&key); - if (g_table[pos].key.face) - return &g_table[pos].glyph; - - /* - * Render the bitmap - */ - subv.x = subx; - subv.y = suby; - - FT_Set_Transform(face, NULL, &subv); - - code = FT_Load_Glyph(face, gid, FT_LOAD_NO_BITMAP | FT_LOAD_NO_HINTING); - if (code < 0) - return NULL; - - code = FT_Render_Glyph(face->glyph, FT_RENDER_MODE_LIGHT); - if (code < 0) - return NULL; - - w = face->glyph->bitmap.width; - h = face->glyph->bitmap.rows; - - /* - * Find an empty slot in the texture - */ - - if (g_table_load == (MAXGLYPHS * 3) / 4) - { - clear_font_cache(); - pos = lookup_table(&key); - } - - if (h + PADDING > g_cache_h || w + PADDING > g_cache_w) - errx(1, "rendered glyph exceeds cache dimensions"); - - if (g_cache_row_x + w + PADDING > g_cache_w) - { - g_cache_row_y += g_cache_row_h + PADDING; - g_cache_row_x = PADDING; - g_cache_row_h = 0; - } - if (g_cache_row_y + h + PADDING > g_cache_h) - { - clear_font_cache(); - pos = lookup_table(&key); - } - - /* - * Copy bitmap into texture - */ - - memcpy(&g_table[pos].key, &key, sizeof(struct key)); - g_table[pos].glyph.w = face->glyph->bitmap.width; - g_table[pos].glyph.h = face->glyph->bitmap.rows; - g_table[pos].glyph.lsb = face->glyph->bitmap_left; - g_table[pos].glyph.top = face->glyph->bitmap_top; - g_table[pos].glyph.s = g_cache_row_x; - g_table[pos].glyph.t = g_cache_row_y; - g_table[pos].glyph.advance = face->glyph->advance.x / 64.0; - g_table_load ++; - - glPixelStorei(GL_UNPACK_ALIGNMENT, 1); - glPixelStorei(GL_UNPACK_ROW_LENGTH, face->glyph->bitmap.pitch); - glTexSubImage2D(GL_TEXTURE_2D, 0, g_cache_row_x, g_cache_row_y, w, h, - GL_ALPHA, GL_UNSIGNED_BYTE, face->glyph->bitmap.buffer); - glPixelStorei(GL_UNPACK_ROW_LENGTH, 0); - - g_cache_row_x += w + PADDING; - if (g_cache_row_h < h + PADDING) - g_cache_row_h = h + PADDING; - - return &g_table[pos].glyph; -} - -static float draw_glyph(FT_Face face, int size, int gid, float x, float y) -{ - struct glyph *glyph; - int subx = (x - floor(x)) * XPRECISION; - int suby = (y - floor(y)) * YPRECISION; - GLfloat *t = state.texcoords; - GLfloat *v = state.vertices; - float s0, t0, s1, t1, xc, yc; - - subx = (subx * 64) / XPRECISION; - suby = (suby * 64) / YPRECISION; - - glyph = lookup_glyph(face, size, gid, subx, suby); - if (!glyph) - return 0.0; - - s0 = (float) glyph->s / g_cache_w; - t0 = (float) glyph->t / g_cache_h; - s1 = (float) (glyph->s + glyph->w) / g_cache_w; - t1 = (float) (glyph->t + glyph->h) / g_cache_h; - xc = floor(x) + glyph->lsb; - yc = floor(y) - glyph->top + glyph->h; - - t[0] = s0; t[1] = t0; v[0] = xc; v[1] = yc - glyph->h; - t[2] = s1; t[3] = t0; v[2] = xc + glyph->w; v[3] = yc - glyph->h; - t[4] = s0; t[5] = t1; v[4] = xc; v[5] = yc; - t[6] = s1; t[7] = t1; v[6] = xc + glyph->w; v[7] = yc; - - glDrawArrays(GL_TRIANGLE_STRIP, 0, 4); - return glyph->advance; -} - -static float measure_string(FT_Face face, float fsize, const char *str) -{ - int size = fsize * 64; - FT_Fixed advance; - Rune ucs, gid; - float w = 0.0; - int left = 0; - - FT_Set_Char_Size(face, size, size, 72, 72); - - while (*str) - { - str += fz_chartorune(&ucs, str); - gid = FT_Get_Char_Index(face, ucs); - FT_Get_Advance(face, gid, FT_LOAD_NO_BITMAP | FT_LOAD_NO_HINTING, &advance); - w += advance / 65536.0; - if (g_use_kern) { - FT_Vector kern; - - FT_Get_Kerning(face, left, gid, FT_KERNING_UNFITTED, &kern); - w += kern.x / 64.0; - } - left = gid; - } - - return w; -} - -static float draw_string(FT_Face face, float fsize, float x, float y, - const char *str) -{ - int size = fsize * 64; - Rune ucs, gid; - int left = 0; - - FT_Set_Char_Size(face, size, size, 72, 72); - - glBindTexture(GL_TEXTURE_2D, g_cache_tex); - glVertexPointer(2, GL_FLOAT, 0, state.vertices); - glTexCoordPointer(2, GL_FLOAT, 0, state.texcoords); - - while (*str) - { - str += fz_chartorune(&ucs, str); - gid = FT_Get_Char_Index(face, ucs); - x += draw_glyph(face, size, gid, x, y); - if (g_use_kern) { - FT_Vector kern; - - FT_Get_Kerning(face, left, gid, FT_KERNING_UNFITTED, &kern); - x += kern.x / 64.0; - } - left = gid; - } - - return x; -} -/* - Local Variables: - c-file-style: "linux" - End: -*/ diff --git a/glutils.ml b/glutils.ml deleted file mode 100644 index a49f879..0000000 --- a/glutils.ml +++ /dev/null @@ -1,34 +0,0 @@ -let vraw = Raw.create_static `float ~len:8 - -let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3 = - Raw.sets_float vraw ~pos:0 [| x0; y0; x1; y1; x2; y2; x3; y3 |]; - GlArray.vertex `two vraw; - GlArray.draw_arrays `triangle_strip ~first:0 ~count:4 - -let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1 - -let filledrect x0 y0 x1 y1 = - GlArray.disable `texture_coord; - filledrect1 x0 y0 x1 y1; - GlArray.enable `texture_coord - -let linerect x0 y0 x1 y1 = - GlArray.disable `texture_coord; - Raw.sets_float vraw ~pos:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |]; - GlArray.vertex `two vraw; - GlArray.draw_arrays `line_loop ~first:0 ~count:4; - GlArray.enable `texture_coord - -let drawstring size x y s = - Gl.enable `blend; - Gl.enable `texture_2d; - GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; - ignore (Ffi.drawstr size x y s); - Gl.disable `blend; - Gl.disable `texture_2d - -let drawstringf size x y = Printf.kprintf (drawstring size (x+1) (y+size+1)) -let redisplay = ref false -let postRedisplay who = - Utils.vlog "redisplay for [%S]" who; - redisplay := true diff --git a/glutils.mli b/glutils.mli deleted file mode 100644 index 4bf5e25..0000000 --- a/glutils.mli +++ /dev/null @@ -1,11 +0,0 @@ -val vraw : [< Raw.kind > `float ] Raw.t -val filledrect2 : - float -> - float -> float -> float -> float -> float -> float -> float -> unit -val filledrect1 : float -> float -> float -> float -> unit -val filledrect : float -> float -> float -> float -> unit -val linerect : float -> float -> float -> float -> unit -val drawstring : int -> int -> int -> string -> unit -val drawstringf : int -> int -> int -> ('a, unit, string, unit) format4 -> 'a -val redisplay : bool ref -val postRedisplay : string -> unit diff --git a/help.ml b/help.ml deleted file mode 100644 index b21ae27..0000000 --- a/help.ml +++ /dev/null @@ -1,207 +0,0 @@ -let keys = -{|-----Quitting----- -escape/q - quit -Q - quit without saving the configuration or changes -W - save changes - ------Movement----- -up/down arrow - scroll up/down -left/right arrow - pan left/right (when zoomed in) -Ctrl-arrows - half a screen width/height scoll/pan -space - go to the next page -delete - go to the previous page -pageup/pagedown - go forward/backward one screen-full -g/G - go to first/last page -home/end - go to first/last page - ------Advanced Movement / History----- -backspace - go back after jumping (clicking link and suchlike)[1] -Alt-left/right arrow - go backward/forward in history -0..9 - enter page number to jump to -t - align top of the screen with the top of the page -<,> - rotate -Ctrl-pageup/pagedown - align top of the screen with first/last visible page -F - go to hinted link -if auto scrolling is active: - up/down arrows and mouse buttons 3/4 will make scrolling go faster/slower - ------Mouse----- -primary mouse button - click on link or select text[2] - when Shift is held - run "synctex command" with coordinates of the point[3] - when Ctrl is held - pan - zoom to block - when in block zoom mode - otherwise - pan if there's no text/link under the cursor -mouse buttons 3/4 - scroll up/down (aka mouse wheel) - when Shift is held - pan left/right - when Ctrl is held - zoom -mouse buttons 5/6 - pan left/right (aka horizontal mouse wheel) -secondary mouse button - select rectangle to zoom to - when Shift is held - add text annotation - -Note: - moving mouse while holding primary mouse button will pan the page, - if the mouse is over selectable element (text/link) holding Ctrl - will make the page pan instead of the default action (selecting text/ - clicking link) - ------Bookmarks----- -m - create named bookmark -~ - create quick bookmark - ------Zoom----- -Ctrl+Shift up/down - set previous zoom level -B - toggle zoom block mode -w - change height of the window to encompass all of the page -Alt-c - center view -Ctrl-+/Ctrl-= - zoom in -Ctrl-- - zoom out -Ctrl-0 - reset zoom and panning -Ctrl-1 - fit tallest page -Ctrl-2 - fit tallest page height exactly -Ctrl-3 - cycle fit models -Ctrl-4 - 1:1 zoom -Ctrl-9/F9 - enter bird's eye view - ------Actions----- -u - dehighlight -r - reload document[4] -y - select link and paste its description to the clipboard -| - pipe selection through specified command -x - run pax command on selected region -Ctrl-p - launch a command with the document path as an argument -return - (in link navigation mode) follow link -= - show current position -e - view error log - ------Search----- -/,? - enter text to search for (/ - forward, ? - backward) -n - repeat last search (forward) -p, N - repeat last search (backward) -z[zbt] - "zoom in" on the first search result -Ctrl-g - interrupt search - ------Settings / Modes----- -[/] - decrease/increase page brightness -+ - set page bias -- - toggle/set tunable -b - toggle scroll bar -l - toggle highlighting of the links -f - toggle fullscreen -insert - toggle link navigation mode -o - switch to outline/table of contents mode -' - switch to bookmark mode -F1 - switch to help mode -Alt-F1 - switch to history mode -i - switch to info mode -P - switch to "presentation" mode -c - switch to previous column layout -a - auto scroll mode - ------Tunables----- --i - toggle case sensitivity of searches --R - rotate --v - toggle verbosity --Z - set zoom (percent) --T - toggle trimming of margins --I - invert colors --M - toggle pax mode --C - set column count --x - set command to run on selection --f - toggle "what's under cursor" identification - - (or "what's currently selected" in link navigation mode) - - (font name of the text under cursor or link target) - ------Bird's eye mode----- -Ctrl-9/F9/esc - leave bird's eye view -Ctrl-l - center the view on the currently selected page -(page)up/(page)down - navigate -home/end - go to first/last page -enter - select the page and leave bird's eye mode -primary mouse button - select the page under cursor and leave bird's eye mode - ------Outline/bookmark/help/info/history mode----- -esc - leave outline/bookmark mode -up/down - select previous/next item -alpha-numeric - quick search -Ctrl-s - repeat search (forward) -Ctrl-r - repeat search (backward) -Ctrl-l - center on current item -Ctrl-left/right - pan text left/right -Ctrl-up/down - scroll view up/down -Ctrl-insert - copy active item's text to clipboard - ------Outline/history mode----- -left/right - go up/down a level -Shift-left/right - go to prev/next item of same or higher level -Ctrl-a - toggle auto narrowing -/ - enter auto narrowing -tab - begin nested narrowing -Ctrl-n - narrow to search pattern -Ctrl-u - undo narrowing -Ctrl-S - synchronize - ------Info mode----- -enter - toggle/enter new value for selected parameter - ------When entering search pattern/page number----- -up/down arrow - previous/next entered text -enter - confirm -Ctrl-g/esc - cancel - -double/triple/quadruple/quintuple clicks in view mode will pipe the -word/line/block/page through pax command when Ctrl is held and -selection command otherwise - -[1] if the document was previously visited initial backspace will - jump to the last visited place - -[2] C&P - -[3] arguments to the command are: - 1 = path to the document - 2 = zero based page number - 3 = X coordinate within the page - 4 = Y … - -[4] document will also be reloaded upon reception of the HUP signal - ------Caveat emptor----- -o Text selection is limited to a single page -o Text searching is very naive|} - -open Utils - -let gotourl launcher url = - let command = Str.global_replace Utils.Re.percents url launcher in - try ignore @@ spawn command [] - with exn -> dolog "failed to execute `%s': %s" command @@ exntos exn - -let gotouri launcher uri = - if emptystr launcher - then dolog "%s" uri - else - if nonemptystr @@ geturl uri - then gotourl launcher uri - else dolog "obtained empty url from uri %S" uri - -let version () = - Printf.sprintf "llpp %s, ocaml %s (%d bit), fitz %s" - (Ffi.llpp_version ()) Sys.ocaml_version Sys.word_size (Ffi.fz_version ()) - -let fixup = - let gr = Str.global_replace in - let dash = Str.regexp {|\([^ ]*\) +- +\(.*\)|} - and head = Str.regexp {|-----\(.*\)-----|} - and wcAp = Str.regexp "C&P" in - fun s -> gr dash "\\1\t\\2" @@ gr head "\xc2\xb7\\1" @@ gr wcAp Wsi.cAp s - -let makehelp launcher = - version () - :: "(searching in this text works just by typing (i.e. no initial '/'))" - :: E.s :: String.split_on_char '\n' keys |> - List.map (fun s -> - let s = fixup s in - match geturl s with - | "" -> (s, 0, None) - | url -> (s, 0, Some (fun uioh -> gotourl launcher url; uioh)) - ) diff --git a/help.mli b/help.mli deleted file mode 100644 index c902d3c..0000000 --- a/help.mli +++ /dev/null @@ -1,4 +0,0 @@ -val gotouri : string -> string -> unit -val gotourl : string -> string -> unit -val makehelp : string -> (string * int * Config.action) list -val version : unit -> string diff --git a/keys.ml b/keys.ml deleted file mode 100644 index 8871ccb..0000000 --- a/keys.ml +++ /dev/null @@ -1,23 +0,0 @@ -type t = - | Ascii of char | Code of int | Ctrl of int | Fn of int - | Backspace | Delete | Escape | Insert | Enter - | Up | Down | Left | Right | Next | Prior | Home | End - -let to_string = function - | Ascii c -> Printf.sprintf "'%c'" c - | Code c -> string_of_int c - | Ctrl c -> Printf.sprintf "ctrl(%#x)" c - | Fn n -> "F" ^ string_of_int n - | Backspace -> "backspace" - | Delete -> "delete" - | Escape -> "escape" - | Insert -> "insert" - | Enter -> "enter" - | Up -> "up" - | Down -> "down" - | Left -> "left" - | Right -> "right" - | Next -> "next" - | Prior -> "prior" - | Home -> "home" - | End -> "end" diff --git a/keys.mli b/keys.mli deleted file mode 100644 index 73e48ec..0000000 --- a/keys.mli +++ /dev/null @@ -1,19 +0,0 @@ -type t = - Ascii of char - | Code of int - | Ctrl of int - | Fn of int - | Backspace - | Delete - | Escape - | Insert - | Enter - | Up - | Down - | Left - | Right - | Next - | Prior - | Home - | End -val to_string : t -> string diff --git a/lablGL/COPYRIGHT b/lablGL/COPYRIGHT deleted file mode 100644 index 13accdc..0000000 --- a/lablGL/COPYRIGHT +++ /dev/null @@ -1,26 +0,0 @@ -Copyright (c) 1997-2001 Jacques Garrigue and Kyoto University. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the University nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. diff --git a/lablGL/gl.ml b/lablGL/gl.ml deleted file mode 100644 index 6ca7931..0000000 --- a/lablGL/gl.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* $Id: gl.ml,v 1.31 2012-03-06 03:31:02 garrigue Exp $ *) - -(* Register an exception *) - -exception GLerror of string - -let _ = Callback.register_exception "glerror" (GLerror "") - -(* Types common to all modules *) - -type rgb = float * float * float -type rgba = float * float * float * float - -type point2 = float * float -type point3 = float * float * float -type point4 = float * float * float * float -type vect3 = float * float *float - -type clampf = float -type short = int -type kind = [`bitmap|`byte|`float|`int|`short|`ubyte|`uint|`ushort] -type real_kind = [`byte|`float|`int|`short|`ubyte|`uint|`ushort] - -type format = - [`alpha|`bgr|`bgra|`blue|`color_index|`depth_component|`green|`luminance - |`luminance_alpha|`red|`rgb|`rgba|`stencil_index] -let format_size (#format as f) = - match f with - `rgba | `bgra -> 4 - | `rgb | `bgr -> 3 - | `luminance_alpha -> 2 - | _ -> 1 - -type target = - [`color_4|`index|`normal|`texture_coord_1|`texture_coord_2|`texture_coord_3 - |`texture_coord_4|`trim_2|`trim_3|`vertex_3|`vertex_4] -let target_size = function - `index|`normal|`texture_coord_1 -> 1 - | `texture_coord_2|`trim_2 -> 2 - | `vertex_3|`texture_coord_3|`trim_3 -> 3 - | `vertex_4|`color_4|`texture_coord_4 -> 4 - -type cmp_func = - [`always|`equal|`gequal|`greater|`lequal|`less|`never|`notequal] -type face = [`back|`both|`front] - -(* Basic functions *) - -external flush : unit -> unit = "ml_glFlush" -external finish : unit -> unit = "ml_glFinish" - -type cap = - [`alpha_test|`auto_normal|`blend|`clip_plane0|`clip_plane1|`clip_plane2 - |`clip_plane3|`clip_plane4|`clip_plane5|`color_material|`cull_face - |`depth_test|`dither|`fog|`light0|`light1|`light2|`light3|`light4|`light5 - |`light6|`light7|`lighting|`line_smooth|`line_stipple - |`index_logic_op |`color_logic_op - |`map1_color_4|`map1_index|`map1_normal|`map1_texture_coord_1 - |`map1_texture_coord_2|`map1_texture_coord_3|`map1_texture_coord_4 - |`map1_vertex_3|`map1_vertex_4|`map2_color_4|`map2_index|`map2_normal - |`map2_texture_coord_1|`map2_texture_coord_2|`map2_texture_coord_3 - |`map2_texture_coord_4|`map2_vertex_3|`map2_vertex_4|`normalize|`point_smooth - |`polygon_offset_fill|`polygon_offset_line|`polygon_offset_point - |`polygon_smooth|`polygon_stipple|`scissor_test|`stencil_test|`texture_1d - |`texture_2d|`texture_gen_q|`texture_gen_r|`texture_gen_s|`texture_gen_t] - -external enable : cap -> unit = "ml_glEnable" -external disable : cap -> unit = "ml_glDisable" -external is_enabled : cap -> bool = "ml_glIsEnabled" - -type error = - [`no_error|`invalid_enum|`invalid_value|`invalid_operation - |`stack_overflow|`stack_underflow|`out_of_memory|`table_too_large] -external get_error : unit -> error = "ml_glGetError" -let raise_error name = - let err = get_error () in - if err = `no_error then () else - let s = - List.assoc err - [ `invalid_enum, "Invalid Enum"; - `invalid_value, "Invalid Value"; - `invalid_operation, "Invalid Operation"; - `stack_overflow, "Stack Overflow"; - `stack_underflow, "Stack Underflow"; - `out_of_memory, "Out of Memory"; - `table_too_large, "Table Too Large" ] - in - let s = if name = "" then s else (name ^ ": " ^ s) in - raise (GLerror s) diff --git a/lablGL/gl.mli b/lablGL/gl.mli deleted file mode 100644 index 8d28c40..0000000 --- a/lablGL/gl.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* $Id: gl.mli,v 1.23 2012-03-06 03:31:02 garrigue Exp $ *) - -(* Exceptions *) - -exception GLerror of string - -(* Types common to all modules *) - -type rgb = float * float * float -type rgba = float * float * float * float - -type point2 = float * float -type point3 = float * float * float -type point4 = float * float * float * float -type vect3 = float * float *float - -type clampf = float -type short = int -type kind = [`bitmap|`byte|`float|`int|`short|`ubyte|`uint|`ushort] -type real_kind = [`byte|`float|`int|`short|`ubyte|`uint|`ushort] - -type format = - [`alpha|`bgr|`bgra|`blue|`color_index|`depth_component|`green|`luminance - |`luminance_alpha|`red|`rgb|`rgba|`stencil_index] -val format_size : [< format] -> int - -type target = - [`color_4|`index|`normal|`texture_coord_1|`texture_coord_2|`texture_coord_3 - |`texture_coord_4|`trim_2|`trim_3|`vertex_3|`vertex_4] -val target_size : [< target] -> int - -type cmp_func = - [`always|`equal|`gequal|`greater|`lequal|`less|`never|`notequal] -type face = [`back|`both|`front] - -(* Basic functions *) - -val flush : unit -> unit -val finish : unit -> unit - -type cap = - [`alpha_test|`auto_normal|`blend|`clip_plane0|`clip_plane1|`clip_plane2 - |`clip_plane3|`clip_plane4|`clip_plane5|`color_material|`cull_face - |`depth_test|`dither|`fog|`light0|`light1|`light2|`light3|`light4|`light5 - |`light6|`light7|`lighting|`line_smooth|`line_stipple - |`index_logic_op |`color_logic_op - |`map1_color_4|`map1_index|`map1_normal|`map1_texture_coord_1 - |`map1_texture_coord_2|`map1_texture_coord_3|`map1_texture_coord_4 - |`map1_vertex_3|`map1_vertex_4|`map2_color_4|`map2_index|`map2_normal - |`map2_texture_coord_1|`map2_texture_coord_2|`map2_texture_coord_3 - |`map2_texture_coord_4|`map2_vertex_3|`map2_vertex_4|`normalize|`point_smooth - |`polygon_offset_fill|`polygon_offset_line|`polygon_offset_point - |`polygon_smooth|`polygon_stipple|`scissor_test|`stencil_test|`texture_1d - |`texture_2d|`texture_gen_q|`texture_gen_r|`texture_gen_s|`texture_gen_t] -val enable : cap -> unit -val disable : cap -> unit -val is_enabled : cap -> bool - -type error = - [`no_error|`invalid_enum|`invalid_value|`invalid_operation - |`stack_overflow|`stack_underflow|`out_of_memory|`table_too_large] -val get_error : unit -> error -val raise_error : string -> unit - (* raise GLerror if there is a current error, otherwise do nothing *) diff --git a/lablGL/glArray.ml b/lablGL/glArray.ml deleted file mode 100644 index 5b8368e..0000000 --- a/lablGL/glArray.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* $Id: glArray.ml,v 1.6 2008-10-30 07:51:33 garrigue Exp $ *) - -open Gl -open Raw - -type kind = [`edge_flag | `texture_coord | `color | `index | `normal | `vertex ] - -let check_static func f raw = - if not (Raw.static raw) then - invalid_arg ("GlArray." ^ func ^ " : buffer must be static"); - f raw - -external _edge_flag : [< `bitmap] Raw.t -> unit = "ml_glEdgeFlagPointer" -let edge_flag raw = check_static "edge_flag" _edge_flag raw - -external _tex_coord : - [< `one | `two | `three | `four] -> - [< `short | `int | `float | `double] Raw.t -> unit - = "ml_glTexCoordPointer" -let tex_coord n = check_static "tex_coord" (_tex_coord n) - -external _color : - [< `three | `four] -> - [< `byte | `ubyte | `short | `ushort | `int | `uint | `float | `double] Raw.t - -> unit - = "ml_glColorPointer" -let color n = check_static "color" (_color n) - -external _index : [< `ubyte | `short | `int | `float | `double] Raw.t -> unit - = "ml_glIndexPointer" -let index raw = check_static "index" _index raw - -external _normal : [< `byte | `short | `int | `float | `double] Raw.t -> unit - = "ml_glNormalPointer" -let normal raw = check_static "normal" _normal raw - -external _vertex : - [< `two | `three | `four] -> [< `short | `int | `float | `double] Raw.t - -> unit - = "ml_glVertexPointer" -let vertex n = check_static "vertex" (_vertex n) - -external enable : kind -> unit= "ml_glEnableClientState" - -external disable : kind -> unit = "ml_glDisableClientState" - -external element : int -> unit = "ml_glArrayElement" - -external draw_arrays : GlDraw.shape -> first:int -> count:int -> unit - = "ml_glDrawArrays" - -external draw_elements - : GlDraw.shape -> count:int -> [< `ubyte | `ushort | `uint] Raw.t -> unit - = "ml_glDrawElements" diff --git a/lablGL/glArray.mli b/lablGL/glArray.mli deleted file mode 100644 index 5cbbe3c..0000000 --- a/lablGL/glArray.mli +++ /dev/null @@ -1,62 +0,0 @@ -(** Vertex array manipulation functions *) -(* $Id: glArray.mli,v 1.7 2008-10-25 02:22:58 garrigue Exp $ *) - -(** The six different kinds for array *) -type kind = - [ `color | `edge_flag | `index | `normal | `texture_coord | `vertex ] - -(** Tell openGL the address of the edgeFlag array. - Raw array must be static. *) -val edge_flag : [ `bitmap ] Raw.t -> unit - -(** Tell openGL the address of the texCoor array - Raw array must be static. *) -val tex_coord : - [< `one | `two | `three | `four] -> - [< `double | `float | `int | `short ] Raw.t -> unit - -(** Tell openGL the address of the color array - Raw array must be static. *) -val color : - [< `three | `four] -> - [< `byte | `double | `float | `int | `short | `ubyte | `uint | `ushort ] - Raw.t -> unit - -(** Tell openGL the address of the index array - Raw array must be static. *) -val index : [< `double | `float | `int | `short | `ubyte ] Raw.t -> unit - -(** Tell openGL the address of the normal array - Raw array must be static. *) -val normal : [< `byte | `double | `float | `int | `short ] Raw.t -> unit - -(** Tell openGL the address of the vertex array - Raw array must be static. *) -val vertex : - [< `two | `three | `four] -> [< `double | `float | `int | `short ] Raw.t - -> unit - -(** Tell openGL the address of to use the specified array - Raw array must be static. *) -external enable : kind -> unit = "ml_glEnableClientState" - -(** Tell openGL the address of not to use the specified array - Raw array must be static. *) -external disable : kind -> unit = "ml_glDisableClientState" - -(* GlArray.element i - sends to openGL the element i of all enabled arrays *) -external element : int -> unit = "ml_glArrayElement" - -(* GlArray.draw_arrays shape i c - sends to openGL a GlDraw.begins shape and all the element from i to i+c-1 - of all enabled arrays and finally do a GlDraw.ends () *) -external draw_arrays : GlDraw.shape -> first:int -> count:int -> unit - = "ml_glDrawArrays" - -(* GlArray.draw_elements shape c tbl - sends to openGL a GlDraw.begins shape and all the element from tbl[0] to - tbl[c-1] of all enabled arrays and finally do a GlDraw.ends () *) -external draw_elements : - GlDraw.shape -> count:int -> [< `ubyte | `uint | `ushort ] Raw.t -> unit - = "ml_glDrawElements" diff --git a/lablGL/glClear.ml b/lablGL/glClear.ml deleted file mode 100644 index be01f1a..0000000 --- a/lablGL/glClear.ml +++ /dev/null @@ -1,20 +0,0 @@ -(* $Id: glClear.ml,v 1.5 2000-04-12 07:40:23 garrigue Exp $ *) - -open Gl - -external accum : float -> float -> float -> float -> unit - = "ml_glClearAccum" -let accum ?(alpha=1.) (r,g,b : rgb) = - accum r g b alpha - -type buffer = [`color|`depth|`accum|`stencil] -external clear : buffer list -> unit = "ml_glClear" - -external color : - red:float -> green:float -> blue:float -> alpha:float -> unit - = "ml_glClearColor" -let color ?(alpha=1.) (red, green, blue : rgb) = - color ~red ~green ~blue ~alpha -external depth : clampf -> unit = "ml_glClearDepth" -external index : float -> unit = "ml_glClearIndex" -external stencil : int -> unit = "ml_glClearStencil" diff --git a/lablGL/glClear.mli b/lablGL/glClear.mli deleted file mode 100644 index dae4c8a..0000000 --- a/lablGL/glClear.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* $Id: glClear.mli,v 1.3 1999-11-15 09:55:05 garrigue Exp $ *) - -type buffer = [`accum|`color|`depth|`stencil] -val clear : buffer list -> unit - (* glClear: clear the specified buffers *) - -val accum : ?alpha:float -> Gl.rgb -> unit -val color : ?alpha:float -> Gl.rgb -> unit -val depth : Gl.clampf -> unit -val index : float -> unit -val stencil : int -> unit - (* Set the clear value for each buffer: glClearAccum etc *) diff --git a/lablGL/glDraw.ml b/lablGL/glDraw.ml deleted file mode 100644 index 8d03070..0000000 --- a/lablGL/glDraw.ml +++ /dev/null @@ -1,55 +0,0 @@ -(* $Id: glDraw.ml,v 1.6 2007-04-13 01:17:50 garrigue Exp $ *) - -open Gl - -external color : red:float -> green:float -> blue:float -> alpha:float -> unit - = "ml_glColor4d" -let color ?(alpha=1.) (red, green, blue : rgb) = - color ~red ~green ~blue ~alpha - -external index : float -> unit = "ml_glIndexd" - -external cull_face : face -> unit = "ml_glCullFace" -external edge_flag : bool -> unit = "ml_glEdgeFlag" -external front_face : [`cw|`ccw] -> unit = "ml_glFrontFace" - -external line_width : float -> unit = "ml_glLineWidth" -external line_stipple : factor:int -> pattern:short -> unit - = "ml_glLineStipple" -let line_stipple ?(factor=1) pattern = - line_stipple ~factor ~pattern -external point_size : float -> unit = "ml_glPointSize" - -external polygon_offset : factor:float -> units:float -> unit - = "ml_glPolygonOffset" -external polygon_mode : face:face -> [`point|`line|`fill] -> unit - = "ml_glPolygonMode" -external polygon_stipple : [`bitmap] Raw.t -> unit = "ml_glPolygonStipple" -let polygon_stipple (img : GlPix.bitmap) = - if GlPix.height img <> 32 || GlPix.width img <> 32 - then invalid_arg "GlDraw.polygon_stipple"; - polygon_stipple (GlPix.to_raw img) - -external shade_model : [`flat|`smooth] -> unit = "ml_glShadeModel" - -type shape = - [ `points | `lines | `polygon | `triangles | `quads | `line_strip - | `line_loop | `triangle_strip | `triangle_fan | `quad_strip ] -external begins : shape -> unit = "ml_glBegin" -external ends : unit -> unit = "ml_glEnd" - -external normal : x:float -> y:float -> z:float -> unit - = "ml_glNormal3d" -let normal ?(x=0.) ?(y=0.) ?(z=0.) () = normal ~x ~y ~z -and normal3 (x,y,z) = normal ~x ~y ~z - -external rect : point2 -> point2 -> unit = "ml_glRectd" - -external vertex : x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit - = "ml_glVertex" -let vertex2 (x,y : point2) = vertex ~x ~y () -and vertex3 (x,y,z : point3) = vertex ~x ~y ~z () -and vertex4 (x,y,z,w : point4) = vertex ~x ~y ~z ~w () - -external viewport : x:int -> y:int -> w:int -> h:int -> unit - = "ml_glViewport" diff --git a/lablGL/glDraw.mli b/lablGL/glDraw.mli deleted file mode 100644 index 7f35774..0000000 --- a/lablGL/glDraw.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* $Id: glDraw.mli,v 1.3 2007-04-13 01:17:50 garrigue Exp $ *) - -open Gl - -val color : ?alpha:float -> rgb -> unit - (* Sets the current color *) -val index : float -> unit - (* Sets the current index *) -val cull_face : face -> unit - (* Specifies which faces are candidates for culling *) -val front_face : [`ccw|`cw] -> unit - (* Specifies wether front faces are clockwise or not *) -val edge_flag : bool -> unit -val line_width : float -> unit -val line_stipple : ?factor:int -> short -> unit - (* [line_stipple :factor pattern] sets the line stipple to the - 16-bit integer [pattern]. Each bit is used [factor] times *) -val point_size : float -> unit -val polygon_offset : factor:float -> units:float -> unit -val polygon_mode : face:face -> [`fill|`line|`point] -> unit -val polygon_stipple : GlPix.bitmap -> unit - -val shade_model : [`flat|`smooth] -> unit - -val normal : ?x:float -> ?y:float -> ?z:float -> unit -> unit -val normal3 : vect3 -> unit - (* [glNormal] *) - -val rect : point2 -> point2 -> unit - -type shape = - [`line_loop|`line_strip|`lines|`points|`polygon|`quad_strip|`quads - |`triangle_fan|`triangle_strip|`triangles] -val begins : shape -> unit -val ends : unit -> unit - -val vertex : x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit -val vertex2 : point2 -> unit -val vertex3 : point3 -> unit -val vertex4 : point4 -> unit - -val viewport : x:int -> y:int -> w:int -> h:int -> unit diff --git a/lablGL/glFunc.ml b/lablGL/glFunc.ml deleted file mode 100644 index 240a12e..0000000 --- a/lablGL/glFunc.ml +++ /dev/null @@ -1,66 +0,0 @@ -(* $Id: glFunc.ml,v 1.7 2000-04-12 07:40:23 garrigue Exp $ *) - -open Gl - -external accum : op:[`accum|`load|`add|`mult|`return] -> float -> unit - = "ml_glAccum" -external alpha_func : cmp_func -> ref:clampf -> unit = "ml_glAlphaFunc" - -type sfactor = [ - `zero - | `one - | `dst_color - | `one_minus_dst_color - | `src_alpha - | `one_minus_src_alpha - | `dst_alpha - | `one_minus_dst_alpha - | `src_alpha_saturate -] -type dfactor = [ - `zero - | `one - | `src_color - | `one_minus_src_color - | `src_alpha - | `one_minus_src_alpha - | `dst_alpha - | `one_minus_dst_alpha -] -external blend_func : src:sfactor -> dst:dfactor -> unit = "ml_glBlendFunc" - -external color_mask : bool -> bool -> bool -> bool -> unit - = "ml_glColorMask" -let color_mask ?(red=false) ?(green=false) ?(blue=false) ?(alpha=false) ()= - color_mask red green blue alpha - -external depth_func : cmp_func -> unit = "ml_glDepthFunc" -external depth_mask : bool -> unit = "ml_glDepthMask" -external depth_range : near:float -> far:float -> unit = "ml_glDepthRange" - -type draw_buffer = - [`none|`front_left|`front_right|`back_left|`back_right - |`front|`back|`left|`right|`front_and_back|`aux of int] -external draw_buffer : draw_buffer -> unit = "ml_glDrawBuffer" - -external index_mask : int -> unit = "ml_glIndexMask" - -type logic_op = - [`clear|`set|`copy|`copy_inverted|`noop|`invert|`And|`nand|`Or|`nor - |`xor|`equiv|`and_reverse|`and_inverted|`or_reverse|`or_inverted] -external logic_op : logic_op -> unit = "ml_glLogicOp" - -type read_buffer = - [`front_left|`front_right|`back_left|`back_right|`front|`back - |`left|`right|`aux of int] -external read_buffer : read_buffer -> unit = "ml_glReadBuffer" - -external stencil_func : cmp_func -> ref:int -> mask:int -> unit - = "ml_glStencilFunc" -external stencil_mask : int -> unit = "ml_glStencilMask" -type stencil_op = [`keep|`zero|`replace|`incr|`decr|`invert] -external stencil_op : - fail:stencil_op -> zfail:stencil_op -> zpass:stencil_op -> unit - = "ml_glStencilOp" -let stencil_op ?(fail=`keep) ?(zfail=`keep) ?(zpass=`keep) () = - stencil_op ~fail ~zfail ~zpass diff --git a/lablGL/glFunc.mli b/lablGL/glFunc.mli deleted file mode 100644 index 51865a2..0000000 --- a/lablGL/glFunc.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* $Id: glFunc.mli,v 1.4 2000-04-03 02:57:41 garrigue Exp $ *) - -val accum : op:[`accum|`add|`load|`mult|`return] -> float -> unit - -val alpha_func : Gl.cmp_func -> ref:Gl.clampf -> unit - -type sfactor = - [`dst_alpha|`dst_color|`one|`one_minus_dst_alpha|`one_minus_dst_color - |`one_minus_src_alpha|`src_alpha|`src_alpha_saturate|`zero] -type dfactor = - [`dst_alpha|`one|`one_minus_dst_alpha|`one_minus_src_alpha - |`one_minus_src_color|`src_alpha|`src_color|`zero] -val blend_func : src:sfactor -> dst:dfactor -> unit - -val color_mask : - ?red:bool -> ?green:bool -> ?blue:bool -> ?alpha:bool -> unit -> unit - -val depth_func : Gl.cmp_func -> unit -val depth_mask : bool -> unit -val depth_range : near:float -> far:float -> unit - -val index_mask : int -> unit - -val stencil_func : Gl.cmp_func -> ref:int -> mask:int -> unit -val stencil_mask : int -> unit -type stencil_op = [`decr|`incr|`invert|`keep|`replace|`zero] -val stencil_op : - ?fail:stencil_op -> ?zfail:stencil_op -> ?zpass:stencil_op -> unit -> unit - -type logic_op = - [`And|`Or|`and_inverted|`and_reverse|`clear|`copy|`copy_inverted|`equiv - |`invert|`nand|`noop|`nor|`or_inverted|`or_reverse|`set|`xor] -val logic_op : logic_op -> unit - -type draw_buffer = - [`aux of int|`back|`back_left|`back_right|`front|`front_and_back|`front_left - |`front_right|`left|`none|`right] -val draw_buffer : draw_buffer -> unit - -type read_buffer = - [`aux of int|`back|`back_left|`back_right|`front|`front_left|`front_right - |`left|`right] -val read_buffer : read_buffer -> unit diff --git a/lablGL/glMat.ml b/lablGL/glMat.ml deleted file mode 100644 index 7b9f392..0000000 --- a/lablGL/glMat.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* $Id: glMat.ml,v 1.11 2005-10-28 02:49:09 garrigue Exp $ *) - -type t = [`double] Raw.t - -external frustum : - x:(float * float) -> y:(float * float) -> z:(float * float) -> unit - = "ml_glFrustum" - -external load_identity : unit -> unit = "ml_glLoadIdentity" -external load : t -> unit = "ml_glLoadMatrixd" -let load m = - if Raw.length m <> 16 then invalid_arg "Gl.load_matrix"; - load m -external load_transpose : t -> unit = "ml_glLoadTransposeMatrixd" -let load_transpose m = - if Raw.length m <> 16 then invalid_arg "Gl.load_transpose_matrix"; - load_transpose m - - -external get_matrix : [`modelview_matrix|`projection_matrix|`texture_matrix] -> t -> unit = "ml_glGetDoublev" -let get_matrix mode = - let model = Raw.create `double ~len:16 in - get_matrix mode model; - model - -external mode : [`modelview|`projection|`texture] -> unit - = "ml_glMatrixMode" -external mult : t -> unit = "ml_glMultMatrixd" -let mult m = - if Raw.length m <> 16 then invalid_arg "Gl.mult_matrix"; - mult m -external mult_transpose : t -> unit = "ml_glMultTransposeMatrixd" -let mult_transpose m = - if Raw.length m <> 16 then invalid_arg "Gl.mult_matrix"; - mult_transpose m - -external ortho : - x:(float * float) -> y:(float * float) -> z:(float * float) -> unit - = "ml_glOrtho" - -external pop : unit -> unit = "ml_glPopMatrix" -external push : unit -> unit = "ml_glPushMatrix" - -external rotate : angle:float -> x:float -> y:float -> z:float -> unit - = "ml_glRotated" -let rotate3 ~angle (x,y,z) = rotate ~angle ~x ~y ~z -let rotate ~angle ?(x=0.) ?(y=0.) ?(z=0.) () = rotate ~angle ~x ~y ~z - -external scale : x:float -> y:float -> z:float -> unit = "ml_glScaled" -let scale3 (x,y,z) = scale ~x ~y ~z -let scale ?(x=0.) ?(y=0.) ?(z=0.) () = scale ~x ~y ~z - -external translate : x:float -> y:float -> z:float -> unit = "ml_glTranslated" -let translate3 (x,y,z) = translate ~x ~y ~z -let translate ?(x=0.) ?(y=0.) ?(z=0.) () = translate ~x ~y ~z - -let of_raw mat = - if Raw.length mat <> 16 then invalid_arg "GlMatrix.of_array"; - mat -external to_raw : t -> [`double] Raw.t = "%identity" - -let of_array m : t = - if Array.length m <> 4 then invalid_arg "GlMatrix.of_array"; - let mat = Raw.create `double ~len:16 in - for i = 0 to 3 do - let arr = Array.unsafe_get m i in - if Array.length arr <> 4 then invalid_arg "GlMatrix.of_array"; - Raw.sets_float mat ~pos:(i*4) arr - done; - mat - -let to_array (mat : t) = - let m = Array.make 4 [||] in - for i = 0 to 3 do - Array.unsafe_set m i (Raw.gets_float mat ~pos:(i*4) ~len:4) - done; - m diff --git a/lablGL/glMat.mli b/lablGL/glMat.mli deleted file mode 100644 index 577f3f6..0000000 --- a/lablGL/glMat.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* $Id: glMat.mli,v 1.6 2003-04-22 03:24:02 erickt Exp $ *) - -open Gl - -type t - -val of_raw : [`double] Raw.t -> t -external to_raw : t -> [`double] Raw.t = "%identity" - (* Those two functions are just the identity, and keep sharing. - [double] Raw.t is a raw array of 16 floating point values - representing as 4x4 matrix *) -val of_array : float array array -> t -val to_array : t -> float array array - -val load : t -> unit -val load_transpose : t -> unit -val mult : t -> unit -val mult_transpose : t -> unit -val load_identity : unit -> unit - -val push : unit -> unit -val pop : unit -> unit - (* Push and pop the matrix on the stack *) - -val mode : [`modelview|`projection|`texture] -> unit -val get_matrix : [`modelview_matrix|`projection_matrix|`texture_matrix] -> t - -val rotate : angle:float -> ?x:float -> ?y:float -> ?z:float -> unit -> unit -val scale : ?x:float -> ?y:float -> ?z:float -> unit -> unit -val translate : ?x:float -> ?y:float -> ?z:float -> unit -> unit - -val rotate3 : angle:float -> vect3 -> unit -val scale3 : point3 -> unit -val translate3 : point3 -> unit - -val ortho : x:float * float -> y:float * float -> z:float * float -> unit -val frustum : x:float * float -> y:float * float -> z:float * float -> unit diff --git a/lablGL/glMisc.ml b/lablGL/glMisc.ml deleted file mode 100644 index 147b753..0000000 --- a/lablGL/glMisc.ml +++ /dev/null @@ -1,63 +0,0 @@ -(* $Id: glMisc.ml,v 1.8 2008-10-25 02:22:58 garrigue Exp $ *) - -open StdLabels - -external get_string : [`vendor|`renderer|`version|`extensions] -> string - = "ml_glGetString" - -let rec check_substring ~sep ~start ~buf s = - let len = String.length s in - if String.length buf < len + start then false else - if String.sub buf ~pos:start ~len = s && - (String.length buf = len + start || buf.[len+start] = sep) then true - else match - try Some (String.index_from buf start sep) with Not_found -> None - with - | None -> false - | Some n -> check_substring ~sep ~start:(n+1) ~buf s - -let check_extension s = - check_substring ~sep:' ' ~start:0 ~buf:(get_string `extensions) s - -type equation = float * float * float * float -external clip_plane : plane:int -> equation -> unit - = "ml_glClipPlane" -let clip_plane ~plane equation = - if plane < 0 || plane > 5 then invalid_arg "Gl.clip_plane"; - clip_plane ~plane equation - -type hint_target = - [`fog|`line_smooth|`perspective_correction|`point_smooth|`polygon_smooth] -external hint : hint_target -> [`fastest|`nicest|`dont_care] -> unit - = "ml_glHint" - -external init_names : unit -> unit = "ml_glInitNames" -external load_name : int -> unit = "ml_glLoadName" -external pop_name : unit -> unit = "ml_glPopName" -external push_name : int -> unit = "ml_glPushName" - -external pop_attrib : unit -> unit = "ml_glPopAttrib" -type attrib = - [ `accum_buffer|`color_buffer|`current|`depth_buffer|`enable|`eval|`fog - | `hint|`lighting|`line|`list|`pixel_mode|`point|`polygon|`polygon_stipple - | `scissor|`stencil_buffer|`texture|`transform|`viewport ] -external push_attrib : attrib list -> unit = "ml_glPushAttrib" - -external pass_through : float -> unit = "ml_glPassThrough" -external render_mode : [`render|`select|`feedback] -> int = "ml_glRenderMode" -external select_buffer : int -> [`uint] Raw.t -> unit = "ml_glSelectBuffer" -let select_buffer raw = - if not (Raw.static raw) then - invalid_arg "GlMisc.select_buffer : buffer must be static"; - select_buffer (Raw.length raw) raw -type feedback_mode = - [`_2d |`_3d |`_3d_color |`_3d_color_texture |`_4d_color_texture] -external feedback_buffer : int -> feedback_mode -> [`float] Raw.t -> unit - = "ml_glFeedbackBuffer" -let feedback_buffer ~mode buf = - if not (Raw.static buf) then - invalid_arg "GlMisc.feedback_buffer : buffer must be static"; - feedback_buffer (Raw.length buf) mode buf - -external scissor : x:int -> y:int -> width:int -> height:int -> unit - = "ml_glScissor" diff --git a/lablGL/glMisc.mli b/lablGL/glMisc.mli deleted file mode 100644 index 763eeb0..0000000 --- a/lablGL/glMisc.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* $Id: glMisc.mli,v 1.6 2008-10-25 02:22:58 garrigue Exp $ *) - -(* Getting information *) -val get_string : [`vendor|`renderer|`version|`extensions] -> string -val check_extension : string -> bool - -(* Clipping planes *) -type equation = float * float * float * float -val clip_plane : plane:int -> equation -> unit - -(* Speed hint *) -type hint_target = - [`fog|`line_smooth|`perspective_correction|`point_smooth|`polygon_smooth] -val hint : hint_target -> [`fastest|`nicest|`dont_care] -> unit - -(* Names *) -val init_names : unit -> unit -val load_name : int -> unit -val push_name : int -> unit -val pop_name : unit -> unit - -type attrib = - [ `accum_buffer|`color_buffer|`current|`depth_buffer|`enable|`eval|`fog - | `hint|`lighting|`line|`list|`pixel_mode|`point|`polygon|`polygon_stipple - | `scissor|`stencil_buffer|`texture|`transform|`viewport ] -val push_attrib : attrib list -> unit -val pop_attrib : unit -> unit - -val render_mode : [`feedback|`render|`select] -> int -val pass_through : float -> unit -val select_buffer : [`uint] Raw.t -> unit - (* argument must be a static Raw.t *) -type feedback_mode = - [`_2d |`_3d |`_3d_color |`_3d_color_texture |`_4d_color_texture] -val feedback_buffer : mode:feedback_mode -> [`float] Raw.t -> unit - (* argument must be a static Raw.t *) - -val scissor : x:int -> y:int -> width:int -> height:int -> unit diff --git a/lablGL/glPix.ml b/lablGL/glPix.ml deleted file mode 100644 index dd5cd7d..0000000 --- a/lablGL/glPix.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* $Id: glPix.ml,v 1.10 2005-10-14 13:35:32 garrigue Exp $ *) - -open Gl - -type ('a,'b) t = { format: 'a ; width: int ; height:int ; raw: 'b Raw.t } - -let create k ~format ~width ~height = - let size = format_size format * width * height in - let len = match k with `bitmap -> (size-1)/8+1 | #Gl.real_kind -> size in - let raw = Raw.create k ~len in - { format = format; width = width; height = height; raw = raw } - -let of_raw raw ~format ~width ~height = - let size = format_size format * width * height - and len = Raw.length raw in - let len = - match Raw.kind raw with `bitmap -> len * 8 | #Gl.real_kind -> len in - if size > len then invalid_arg "GlPix.of_raw"; - { format = format; width = width; height = height; raw = raw } - -let to_raw img = img.raw -let format img = img.format -let width img = img.width -let height img = img.height - -let raw_pos img = - let width = - match Raw.kind img.raw with `bitmap -> (img.width-1)/8+1 - | #Gl.real_kind -> img.width - in - let stride = format_size img.format in - let line = stride * width in - fun ~x ~y -> x * stride + y * line - -external bitmap : - width:int -> height:int -> orig:point2 -> move:point2 -> - [`bitmap] Raw.t -> unit - = "ml_glBitmap" -type bitmap = ([`color_index], [`bitmap]) t -let bitmap (img : bitmap) = - bitmap ~width:img.width ~height:img.height img.raw - -external copy : - x:int -> y:int -> width:int -> height:int -> - buffer:[`color|`depth|`stencil] -> unit - = "ml_glCopyPixels" - -external draw : - width:int -> height:int -> format:[< format] -> [< Gl.kind] Raw.t -> unit - = "ml_glDrawPixels" -let draw img = - draw img.raw ~width:img.width ~height:img.height ~format:img.format - -type map = - [`i_to_i|`i_to_r|`i_to_g|`i_to_b|`i_to_a - |`s_to_s|`r_to_r|`g_to_g|`b_to_b|`a_to_a] -external map : map -> [`float] Raw.t -> unit - = "ml_glPixelMapfv" - -type store_param = [ - `pack_swap_bytes of bool - | `pack_lsb_first of bool - | `pack_row_length of int - | `pack_skip_pixels of int - | `pack_skip_rows of int - | `pack_alignment of int - | `unpack_swap_bytes of bool - | `unpack_lsb_first of bool - | `unpack_row_length of int - | `unpack_skip_pixels of int - | `unpack_skip_rows of int - | `unpack_alignment of int -] -external store : store_param -> unit = "ml_glPixelStorei" - -type transfer_param = [ - `map_color of bool - | `map_stencil of bool - | `index_shift of int - | `index_offset of int - | `red_scale of float - | `red_bias of float - | `green_scale of float - | `green_bias of float - | `blue_scale of float - | `blue_bias of float - | `alpha_scale of float - | `alpha_bias of float - | `depth_scale of float - | `depth_bias of float -] -external transfer : transfer_param -> unit = "ml_glPixelTransfer" - -external zoom : x:float -> y:float -> unit = "ml_glPixelZoom" - -external raster_pos : - x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit - = "ml_glRasterPos" - -external read : - x:int -> y:int -> width:int -> height:int -> - format:[< format] -> [< Gl.kind] Raw.t -> unit - = "ml_glReadPixels_bc" "ml_glReadPixels" -let read ~x ~y ~width ~height ~format ~kind = - let raw = Raw.create kind ~len:(width * height * format_size format) in - read ~x ~y ~width ~height ~format raw; - { raw = raw; width = width; height = height; format = format } diff --git a/lablGL/glPix.mli b/lablGL/glPix.mli deleted file mode 100644 index 545f4fa..0000000 --- a/lablGL/glPix.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* $Id: glPix.mli,v 1.9 2004-12-02 02:01:16 garrigue Exp $ *) - -(* An abstract type for pixmaps *) - -type (+'a,+'b) t - -val create : - ([< Gl.kind] as 'a) -> - format:([< Gl.format] as 'b) -> width:int -> height:int -> ('b, 'a) t - -val of_raw : - ([< Gl.kind] as 'a) Raw.t -> - format:([< Gl.format] as 'b) -> width:int -> height:int -> ('b, 'a) t -val to_raw : ('a, 'b) t -> 'b Raw.t -val format : ('a, 'b) t -> 'a -val width : ('a, 'b) t -> int -val height : ('a, 'b) t -> int -val raw_pos : ([< Gl.format], [< Gl.kind]) t -> x:int -> y:int -> int - (* [raw_pos image :x :y] partially evaluates on [image] *) - -(* openGL functions *) - -val read : - x:int -> - y:int -> - width:int -> - height:int -> - format:([< Gl.format] as 'a) -> kind:([< Gl.kind] as 'b) -> ('a, 'b) t - -type bitmap = ([`color_index], [`bitmap]) t -val bitmap : - bitmap -> orig:Gl.point2 -> move:Gl.point2 -> unit - -val draw : ([< Gl.format], [< Gl.kind]) t -> unit - -type map = - [`a_to_a|`b_to_b|`g_to_g|`i_to_a|`i_to_b - |`i_to_g|`i_to_i|`i_to_r|`r_to_r|`s_to_s] -val map : map -> [`float] Raw.t -> unit - -type store_param = [ - `pack_swap_bytes of bool - | `pack_lsb_first of bool - | `pack_row_length of int - | `pack_skip_pixels of int - | `pack_skip_rows of int - | `pack_alignment of int - | `unpack_swap_bytes of bool - | `unpack_lsb_first of bool - | `unpack_row_length of int - | `unpack_skip_pixels of int - | `unpack_skip_rows of int - | `unpack_alignment of int -] -val store : store_param -> unit - -type transfer_param = [ - `map_color of bool - | `map_stencil of bool - | `index_shift of int - | `index_offset of int - | `red_scale of float - | `red_bias of float - | `green_scale of float - | `green_bias of float - | `blue_scale of float - | `blue_bias of float - | `alpha_scale of float - | `alpha_bias of float - | `depth_scale of float - | `depth_bias of float -] -val transfer : transfer_param -> unit - -val zoom : x:float -> y:float -> unit -val raster_pos : x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit - -val copy : - x:int -> - y:int -> width:int -> height:int -> buffer:[`color|`depth|`stencil] -> unit diff --git a/lablGL/glTex.ml b/lablGL/glTex.ml deleted file mode 100644 index f18abb9..0000000 --- a/lablGL/glTex.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* $Id: glTex.ml,v 1.14 2012-03-06 03:31:02 garrigue Exp $ *) - -open Gl -open GlPix - -external coord1 : float -> unit = "ml_glTexCoord1d" -external coord2 : float -> float -> unit = "ml_glTexCoord2d" -external coord3 : float -> float -> float -> unit = "ml_glTexCoord3d" -external coord4 : float -> float -> float -> float -> unit - = "ml_glTexCoord4d" - -(*external multi_coord2 : *) - -let default x = function Some x -> x | None -> x -let coord ~s ?t ?r ?q () = - match q with - Some q -> coord4 s (default 0.0 t) (default 0.0 r) q - | None -> match r with - Some r -> coord3 s (default 0.0 t) r - | None -> match t with - Some t -> coord2 s t - | None -> coord1 s -let coord2 (s,t) = coord2 s t -let coord3 (s,t,r) = coord3 s t r -let coord4 (s,t,r,q) = coord4 s t r q -type env_param = [ - `mode of [`modulate|`decal|`blend|`replace] - | `color of rgba -] -external env : env_param -> unit = "ml_glTexEnv" -type coord = [`s|`t|`r|`q] -type gen_param = [ - `mode of [`object_linear|`eye_linear|`sphere_map] - | `object_plane of point4 - | `eye_plane of point4 -] -external gen : coord:coord -> gen_param -> unit = "ml_glTexGen" - -let npot = ref None - -let check_pow2 n = - if !npot = None then - npot := Some (GlMisc.check_extension "GL_ARB_texture_non_power_of_two"); - (!npot = Some true) || (n land (n - 1) = 0) - -type format = [ - `color_index - | `red - | `green - | `blue - | `alpha - | `rgb - | `bgr - | `rgba - | `bgra - | `luminance - | `luminance_alpha -] - -external image1d : - proxy:bool -> level:int -> internal:int -> - width:int -> border:int -> format:[< format] -> [< kind] Raw.t -> unit - = "ml_glTexImage1D_bc""ml_glTexImage1D" -let image1d ?(proxy=false) ?(level=0) ?internal:i ?(border=false) img = - let internal = match i with None -> format_size (format img) | Some i -> i in - let border = if border then 1 else 0 in - if not (check_pow2 (width img - 2 * border)) then - raise (GLerror "Gl.image1d : bad width"); - if height img < 1 then raise (GLerror "Gl.image1d : bad height"); - image1d ~proxy ~level ~internal ~width:(width img) ~border - ~format:(format img) (to_raw img) -external image2d : - proxy:bool -> level:int -> internal:int -> width:int -> - height:int -> border:int -> format:[< format] -> [< kind] Raw.t -> unit - = "ml_glTexImage2D_bc""ml_glTexImage2D" -let image2d ?(proxy=false) ?(level=0) ?internal:i ?(border=false) img = - let internal = match i with None -> format_size (format img) | Some i -> i in - let border = if border then 1 else 0 in - if not (check_pow2 (width img - 2 * border)) then - raise (GLerror "Gl.image2d : bad width"); - if not (check_pow2 (height img - 2 * border)) then - raise (GLerror "Gl.image2d : bad height"); - image2d ~proxy ~level ~internal ~border - ~width:(width img) ~height:(height img) ~format:(format img) (to_raw img) -type filter = [ - `nearest - | `linear - | `nearest_mipmap_nearest - | `linear_mipmap_nearest - | `nearest_mipmap_linear - | `linear_mipmap_linear -] -type wrap = [`clamp|`repeat] -type parameter = [ - `min_filter of filter - | `mag_filter of [`nearest|`linear] - | `wrap_s of wrap - | `wrap_t of wrap - | `border_color of rgba - | `priority of clampf - | `generate_mipmap of bool -] -external parameter : target:[`texture_1d|`texture_2d] -> parameter -> unit - = "ml_glTexParameter" - -type texture_id = nativeint -external _gen_textures : int -> [`uint] Raw.t -> unit = "ml_glGenTextures" -let gen_textures ~len = - let raw = Raw.create `uint ~len in - _gen_textures len raw; - let arr = Array.make len Nativeint.zero in - for i = 0 to len - 1 do - arr.(i) <- Raw.get_long raw ~pos:i - done; - arr -let gen_texture () = (gen_textures ~len:1).(0) - -external bind_texture : target:[`texture_1d|`texture_2d] -> texture_id -> unit - = "ml_glBindTexture" -external delete_texture : texture_id -> unit = "ml_glDeleteTexture" -let delete_textures a = Array.iter (fun id -> delete_texture id) a diff --git a/lablGL/glTex.mli b/lablGL/glTex.mli deleted file mode 100644 index a779b26..0000000 --- a/lablGL/glTex.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* $Id: glTex.mli,v 1.8 2012-03-06 03:31:02 garrigue Exp $ *) - -open Gl - -val coord : s:float -> ?t:float -> ?r:float -> ?q:float -> unit -> unit -val coord2 : float * float -> unit -val coord3 : float * float * float -> unit -val coord4 : float * float * float * float -> unit - -type env_param = [ - `mode of [`modulate|`decal|`blend|`replace] - | `color of rgba] -val env : env_param -> unit - -type coord = [`s|`t|`r|`q] -type gen_param = [ - `mode of [`object_linear|`eye_linear|`sphere_map] - | `object_plane of point4 - | `eye_plane of point4 -] -val gen : coord:coord -> gen_param -> unit - -type format = - [`color_index|`red|`green|`blue|`alpha|`rgb|`bgr|`rgba|`bgra - |`luminance|`luminance_alpha] -val image1d : - ?proxy:bool -> ?level:int -> ?internal:int -> ?border:bool -> - ([< format], [< kind]) GlPix.t -> unit -val image2d : - ?proxy:bool -> ?level:int -> ?internal:int -> ?border:bool -> - ([< format], [< kind]) GlPix.t -> unit - -type filter = - [`nearest|`linear|`nearest_mipmap_nearest|`linear_mipmap_nearest - |`nearest_mipmap_linear|`linear_mipmap_linear] -type wrap = [`clamp|`repeat] -type parameter = [ - `min_filter of filter - | `mag_filter of [`nearest|`linear] - | `wrap_s of wrap - | `wrap_t of wrap - | `border_color of rgba - | `priority of clampf - | `generate_mipmap of bool -] -val parameter : target:[`texture_1d|`texture_2d] -> parameter -> unit - -type texture_id -val gen_texture : unit -> texture_id -val gen_textures : len:int -> texture_id array -val bind_texture : target:[`texture_1d|`texture_2d] -> texture_id -> unit -val delete_texture : texture_id -> unit -val delete_textures : texture_id array -> unit diff --git a/lablGL/gl_tags.c b/lablGL/gl_tags.c deleted file mode 100644 index a3bf655..0000000 --- a/lablGL/gl_tags.c +++ /dev/null @@ -1,259 +0,0 @@ - {MLTAG_color, GL_COLOR}, - {MLTAG_depth, GL_DEPTH}, - {MLTAG_accum, GL_ACCUM}, - {MLTAG_stencil, GL_STENCIL}, - {MLTAG_points, GL_POINTS}, - {MLTAG_lines, GL_LINES}, - {MLTAG_polygon, GL_POLYGON}, - {MLTAG_triangles, GL_TRIANGLES}, - {MLTAG_quads, GL_QUADS}, - {MLTAG_line_strip, GL_LINE_STRIP}, - {MLTAG_line_loop, GL_LINE_LOOP}, - {MLTAG_triangle_strip, GL_TRIANGLE_STRIP}, - {MLTAG_triangle_fan, GL_TRIANGLE_FAN}, - {MLTAG_quad_strip, GL_QUAD_STRIP}, - {MLTAG_front, GL_FRONT}, - {MLTAG_back, GL_BACK}, - {MLTAG_both, GL_FRONT_AND_BACK}, - {MLTAG_point, GL_POINT}, - {MLTAG_line, GL_LINE}, - {MLTAG_fill, GL_FILL}, - {MLTAG_cw, GL_CW}, - {MLTAG_ccw, GL_CCW}, - {MLTAG_modelview, GL_MODELVIEW}, - {MLTAG_projection, GL_PROJECTION}, - {MLTAG_texture, GL_TEXTURE}, - {MLTAG_modelview_matrix, GL_MODELVIEW_MATRIX}, - {MLTAG_projection_matrix, GL_PROJECTION_MATRIX}, - {MLTAG_texture_matrix, GL_TEXTURE_MATRIX}, - {MLTAG_alpha_test, GL_ALPHA_TEST}, - {MLTAG_auto_normal, GL_AUTO_NORMAL}, - {MLTAG_blend, GL_BLEND}, - {MLTAG_clip_plane0, GL_CLIP_PLANE0}, - {MLTAG_clip_plane1, GL_CLIP_PLANE1}, - {MLTAG_clip_plane2, GL_CLIP_PLANE2}, - {MLTAG_clip_plane3, GL_CLIP_PLANE3}, - {MLTAG_clip_plane4, GL_CLIP_PLANE4}, - {MLTAG_clip_plane5, GL_CLIP_PLANE5}, - {MLTAG_color_material, GL_COLOR_MATERIAL}, - {MLTAG_cull_face, GL_CULL_FACE}, - {MLTAG_depth_test, GL_DEPTH_TEST}, - {MLTAG_dither, GL_DITHER}, - {MLTAG_fog, GL_FOG}, - {MLTAG_light0, GL_LIGHT0}, - {MLTAG_light1, GL_LIGHT1}, - {MLTAG_light2, GL_LIGHT2}, - {MLTAG_light3, GL_LIGHT3}, - {MLTAG_light4, GL_LIGHT4}, - {MLTAG_light5, GL_LIGHT5}, - {MLTAG_light6, GL_LIGHT6}, - {MLTAG_light7, GL_LIGHT7}, - {MLTAG_lighting, GL_LIGHTING}, - {MLTAG_line_smooth, GL_LINE_SMOOTH}, - {MLTAG_line_stipple, GL_LINE_STIPPLE}, - {MLTAG_logic_op, GL_LOGIC_OP}, - {MLTAG_index_logic_op, GL_INDEX_LOGIC_OP}, - {MLTAG_color_logic_op, GL_COLOR_LOGIC_OP}, - {MLTAG_map1_color_4, GL_MAP1_COLOR_4}, - {MLTAG_map1_index, GL_MAP1_INDEX}, - {MLTAG_map1_normal, GL_MAP1_NORMAL}, - {MLTAG_map1_texture_coord_1, GL_MAP1_TEXTURE_COORD_1}, - {MLTAG_map1_texture_coord_2, GL_MAP1_TEXTURE_COORD_2}, - {MLTAG_map1_texture_coord_3, GL_MAP1_TEXTURE_COORD_3}, - {MLTAG_map1_texture_coord_4, GL_MAP1_TEXTURE_COORD_4}, - {MLTAG_map1_vertex_3, GL_MAP1_VERTEX_3}, - {MLTAG_map1_vertex_4, GL_MAP1_VERTEX_4}, - {MLTAG_map2_color_4, GL_MAP2_COLOR_4}, - {MLTAG_map2_index, GL_MAP2_INDEX}, - {MLTAG_map2_normal, GL_MAP2_NORMAL}, - {MLTAG_map2_texture_coord_1, GL_MAP2_TEXTURE_COORD_1}, - {MLTAG_map2_texture_coord_2, GL_MAP2_TEXTURE_COORD_2}, - {MLTAG_map2_texture_coord_3, GL_MAP2_TEXTURE_COORD_3}, - {MLTAG_map2_texture_coord_4, GL_MAP2_TEXTURE_COORD_4}, - {MLTAG_map2_vertex_3, GL_MAP2_VERTEX_3}, - {MLTAG_map2_vertex_4, GL_MAP2_VERTEX_4}, - {MLTAG_normalize, GL_NORMALIZE}, - {MLTAG_point_smooth, GL_POINT_SMOOTH}, - {MLTAG_polygon_offset_fill, GL_POLYGON_OFFSET_FILL}, - {MLTAG_polygon_offset_line, GL_POLYGON_OFFSET_LINE}, - {MLTAG_polygon_offset_point, GL_POLYGON_OFFSET_POINT}, - {MLTAG_polygon_smooth, GL_POLYGON_SMOOTH}, - {MLTAG_polygon_stipple, GL_POLYGON_STIPPLE}, - {MLTAG_scissor_test, GL_SCISSOR_TEST}, - {MLTAG_stencil_test, GL_STENCIL_TEST}, - {MLTAG_texture_1d, GL_TEXTURE_1D}, - {MLTAG_texture_2d, GL_TEXTURE_2D}, - {MLTAG_texture_gen_q, GL_TEXTURE_GEN_Q}, - {MLTAG_texture_gen_r, GL_TEXTURE_GEN_R}, - {MLTAG_texture_gen_s, GL_TEXTURE_GEN_S}, - {MLTAG_texture_gen_t, GL_TEXTURE_GEN_T}, - {MLTAG_flat, GL_FLAT}, - {MLTAG_smooth, GL_SMOOTH}, - {MLTAG_ambient, GL_AMBIENT}, - {MLTAG_diffuse, GL_DIFFUSE}, - {MLTAG_specular, GL_SPECULAR}, - {MLTAG_position, GL_POSITION}, - {MLTAG_spot_direction, GL_SPOT_DIRECTION}, - {MLTAG_spot_exponent, GL_SPOT_EXPONENT}, - {MLTAG_spot_cutoff, GL_SPOT_CUTOFF}, - {MLTAG_constant_attenuation, GL_CONSTANT_ATTENUATION}, - {MLTAG_linear_attenuation, GL_LINEAR_ATTENUATION}, - {MLTAG_quadratic_attenuation, GL_QUADRATIC_ATTENUATION}, - {MLTAG_emission, GL_EMISSION}, - {MLTAG_shininess, GL_SHININESS}, - {MLTAG_ambient_and_diffuse, GL_AMBIENT_AND_DIFFUSE}, - {MLTAG_color_indexes, GL_COLOR_INDEXES}, - {MLTAG_never, GL_NEVER}, - {MLTAG_less, GL_LESS}, - {MLTAG_equal, GL_EQUAL}, - {MLTAG_lequal, GL_LEQUAL}, - {MLTAG_greater, GL_GREATER}, - {MLTAG_notequal, GL_NOTEQUAL}, - {MLTAG_gequal, GL_GEQUAL}, - {MLTAG_always, GL_ALWAYS}, - {MLTAG_zero, GL_ZERO}, - {MLTAG_one, GL_ONE}, - {MLTAG_dst_color, GL_DST_COLOR}, - {MLTAG_one_minus_dst_color, GL_ONE_MINUS_DST_COLOR}, - {MLTAG_src_alpha, GL_SRC_ALPHA}, - {MLTAG_one_minus_src_alpha, GL_ONE_MINUS_SRC_ALPHA}, - {MLTAG_dst_alpha, GL_DST_ALPHA}, - {MLTAG_one_minus_dst_alpha, GL_ONE_MINUS_DST_ALPHA}, - {MLTAG_src_alpha_saturate, GL_SRC_ALPHA_SATURATE}, - {MLTAG_src_color, GL_SRC_COLOR}, - {MLTAG_one_minus_src_color, GL_ONE_MINUS_SRC_COLOR}, - {MLTAG_linear, GL_LINEAR}, - {MLTAG_exp, GL_EXP}, - {MLTAG_exp2, GL_EXP2}, - {MLTAG_compile, GL_COMPILE}, - {MLTAG_compile_and_execute, GL_COMPILE_AND_EXECUTE}, - {MLTAG_bitmap, GL_BITMAP}, - {MLTAG_byte, GL_BYTE}, - {MLTAG_short, GL_SHORT}, - {MLTAG_int, GL_INT}, - {MLTAG_float, GL_FLOAT}, - {MLTAG_double, GL_DOUBLE}, - {MLTAG_ubyte, GL_UNSIGNED_BYTE}, - {MLTAG_ushort, GL_UNSIGNED_SHORT}, - {MLTAG_uint, GL_UNSIGNED_INT}, - {MLTAG_load, GL_LOAD}, - {MLTAG_add, GL_ADD}, - {MLTAG_mult, GL_MULT}, - {MLTAG_return, GL_RETURN}, - {MLTAG_color_index, GL_COLOR_INDEX}, - {MLTAG_stencil_index, GL_STENCIL_INDEX}, - {MLTAG_depth_component, GL_DEPTH_COMPONENT}, - {MLTAG_rgb, GL_RGB}, - {MLTAG_bgr, GL_BGR}, - {MLTAG_rgba, GL_RGBA}, - {MLTAG_bgra, GL_BGRA}, - {MLTAG_red, GL_RED}, - {MLTAG_green, GL_GREEN}, - {MLTAG_blue, GL_BLUE}, - {MLTAG_alpha, GL_ALPHA}, - {MLTAG_luminance, GL_LUMINANCE}, - {MLTAG_luminance_alpha, GL_LUMINANCE_ALPHA}, - {MLTAG_dont_care, GL_DONT_CARE}, - {MLTAG_fastest, GL_FASTEST}, - {MLTAG_nicest, GL_NICEST}, - {MLTAG_clear, GL_CLEAR}, - {MLTAG_set, GL_SET}, - {MLTAG_copy, GL_COPY}, - {MLTAG_copy_inverted, GL_COPY_INVERTED}, - {MLTAG_noop, GL_NOOP}, - {MLTAG_invert, GL_INVERT}, - {MLTAG_And, GL_AND}, - {MLTAG_nand, GL_NAND}, - {MLTAG_Or, GL_OR}, - {MLTAG_nor, GL_NOR}, - {MLTAG_xor, GL_XOR}, - {MLTAG_equiv, GL_EQUIV}, - {MLTAG_and_reverse, GL_AND_REVERSE}, - {MLTAG_and_inverted, GL_AND_INVERTED}, - {MLTAG_or_reverse, GL_OR_REVERSE}, - {MLTAG_or_inverted, GL_OR_INVERTED}, - {MLTAG_alpha_bias, GL_ALPHA_BIAS}, - {MLTAG_alpha_scale, GL_ALPHA_SCALE}, - {MLTAG_blue_bias, GL_BLUE_BIAS}, - {MLTAG_blue_scale, GL_BLUE_SCALE}, - {MLTAG_depth_bias, GL_DEPTH_BIAS}, - {MLTAG_depth_scale, GL_DEPTH_SCALE}, - {MLTAG_green_bias, GL_GREEN_BIAS}, - {MLTAG_green_scale, GL_GREEN_SCALE}, - {MLTAG_index_offset, GL_INDEX_OFFSET}, - {MLTAG_index_shift, GL_INDEX_SHIFT}, - {MLTAG_map_color, GL_MAP_COLOR}, - {MLTAG_map_stencil, GL_MAP_STENCIL}, - {MLTAG_red_bias, GL_RED_BIAS}, - {MLTAG_red_scale, GL_RED_SCALE}, - {MLTAG_i_to_i, GL_PIXEL_MAP_I_TO_I}, - {MLTAG_i_to_r, GL_PIXEL_MAP_I_TO_R}, - {MLTAG_i_to_g, GL_PIXEL_MAP_I_TO_G}, - {MLTAG_i_to_b, GL_PIXEL_MAP_I_TO_B}, - {MLTAG_i_to_a, GL_PIXEL_MAP_I_TO_A}, - {MLTAG_s_to_s, GL_PIXEL_MAP_S_TO_S}, - {MLTAG_r_to_r, GL_PIXEL_MAP_R_TO_R}, - {MLTAG_g_to_g, GL_PIXEL_MAP_G_TO_G}, - {MLTAG_b_to_b, GL_PIXEL_MAP_B_TO_B}, - {MLTAG_a_to_a, GL_PIXEL_MAP_A_TO_A}, - {MLTAG_pack_swap_bytes, GL_PACK_SWAP_BYTES}, - {MLTAG_pack_lsb_first, GL_PACK_LSB_FIRST}, - {MLTAG_pack_row_length, GL_PACK_ROW_LENGTH}, - {MLTAG_pack_skip_pixels, GL_PACK_SKIP_PIXELS}, - {MLTAG_pack_skip_rows, GL_PACK_SKIP_ROWS}, - {MLTAG_pack_alignment, GL_PACK_ALIGNMENT}, - {MLTAG_unpack_swap_bytes, GL_UNPACK_SWAP_BYTES}, - {MLTAG_unpack_lsb_first, GL_UNPACK_LSB_FIRST}, - {MLTAG_unpack_row_length, GL_UNPACK_ROW_LENGTH}, - {MLTAG_unpack_skip_pixels, GL_UNPACK_SKIP_PIXELS}, - {MLTAG_unpack_skip_rows, GL_UNPACK_SKIP_ROWS}, - {MLTAG_unpack_alignment, GL_UNPACK_ALIGNMENT}, - {MLTAG_front_left, GL_FRONT_LEFT}, - {MLTAG_front_right, GL_FRONT_RIGHT}, - {MLTAG_back_left, GL_BACK_LEFT}, - {MLTAG_back_right, GL_BACK_RIGHT}, - {MLTAG_left, GL_LEFT}, - {MLTAG_right, GL_RIGHT}, - {MLTAG_none, GL_NONE}, - {MLTAG_keep, GL_KEEP}, - {MLTAG_replace, GL_REPLACE}, - {MLTAG_incr, GL_INCR}, - {MLTAG_decr, GL_DECR}, - {MLTAG_modulate, GL_MODULATE}, - {MLTAG_decal, GL_DECAL}, - {MLTAG_s, GL_S}, - {MLTAG_t, GL_T}, - {MLTAG_r, GL_R}, - {MLTAG_q, GL_Q}, - {MLTAG_object_plane, GL_OBJECT_PLANE}, - {MLTAG_eye_plane, GL_EYE_PLANE}, - {MLTAG_eye_linear, GL_EYE_LINEAR}, - {MLTAG_object_linear, GL_OBJECT_LINEAR}, - {MLTAG_sphere_map, GL_SPHERE_MAP}, - {MLTAG_min_filter, GL_TEXTURE_MIN_FILTER}, - {MLTAG_mag_filter, GL_TEXTURE_MAG_FILTER}, - {MLTAG_wrap_s, GL_TEXTURE_WRAP_S}, - {MLTAG_wrap_t, GL_TEXTURE_WRAP_T}, - {MLTAG_border_color, GL_TEXTURE_BORDER_COLOR}, - {MLTAG_priority, GL_TEXTURE_PRIORITY}, - {MLTAG_nearest, GL_NEAREST}, - {MLTAG_nearest_mipmap_nearest, GL_NEAREST_MIPMAP_NEAREST}, - {MLTAG_linear_mipmap_nearest, GL_LINEAR_MIPMAP_NEAREST}, - {MLTAG_nearest_mipmap_linear, GL_NEAREST_MIPMAP_LINEAR}, - {MLTAG_linear_mipmap_linear, GL_LINEAR_MIPMAP_LINEAR}, - {MLTAG_generate_mipmap, GL_GENERATE_MIPMAP}, - {MLTAG_clamp, GL_CLAMP}, - {MLTAG_repeat, GL_REPEAT}, - {MLTAG_vendor, GL_VENDOR}, - {MLTAG_renderer, GL_RENDERER}, - {MLTAG_version, GL_VERSION}, - {MLTAG_extensions, GL_EXTENSIONS}, - {MLTAG_render, GL_RENDER}, - {MLTAG_select, GL_SELECT}, - {MLTAG_feedback, GL_FEEDBACK}, - {MLTAG__2d, GL_2D}, - {MLTAG__3d, GL_3D}, - {MLTAG__3d_color, GL_3D_COLOR}, - {MLTAG__3d_color_texture, GL_3D_COLOR_TEXTURE}, - {MLTAG__4d_color_texture, GL_4D_COLOR_TEXTURE}, -#define TAG_NUMBER 258 diff --git a/lablGL/gl_tags.h b/lablGL/gl_tags.h deleted file mode 100644 index df847c8..0000000 --- a/lablGL/gl_tags.h +++ /dev/null @@ -1,307 +0,0 @@ -#define MLTAG_color Val_int(-899911325) -#define MLTAG_depth Val_int(-685117181) -#define MLTAG_accum Val_int(463071705) -#define MLTAG_stencil Val_int(245244) -#define MLTAG_points Val_int(-147975645) -#define MLTAG_lines Val_int(-184427009) -#define MLTAG_polygon Val_int(311493242) -#define MLTAG_triangles Val_int(-12504917) -#define MLTAG_quads Val_int(-572033588) -#define MLTAG_line_strip Val_int(538124557) -#define MLTAG_line_loop Val_int(781604303) -#define MLTAG_triangle_strip Val_int(443326177) -#define MLTAG_triangle_fan Val_int(-575028580) -#define MLTAG_quad_strip Val_int(867377696) -#define MLTAG_front Val_int(109975721) -#define MLTAG_back Val_int(-1055860185) -#define MLTAG_both Val_int(-1055160191) -#define MLTAG_point Val_int(-963660720) -#define MLTAG_line Val_int(-944564236) -#define MLTAG_fill Val_int(-1011102077) -#define MLTAG_cw Val_int(22196) -#define MLTAG_ccw Val_int(4945367) -#define MLTAG_modelview Val_int(1001184910) -#define MLTAG_projection Val_int(-997488497) -#define MLTAG_texture Val_int(518047963) -#define MLTAG_modelview_matrix Val_int(-184191214) -#define MLTAG_projection_matrix Val_int(484605745) -#define MLTAG_texture_matrix Val_int(-22077339) -#define MLTAG_alpha_test Val_int(226674707) -#define MLTAG_auto_normal Val_int(930283575) -#define MLTAG_blend Val_int(888465489) -#define MLTAG_clip_plane0 Val_int(648785699) -#define MLTAG_clip_plane1 Val_int(648785700) -#define MLTAG_clip_plane2 Val_int(648785701) -#define MLTAG_clip_plane3 Val_int(648785702) -#define MLTAG_clip_plane4 Val_int(648785703) -#define MLTAG_clip_plane5 Val_int(648785704) -#define MLTAG_color_material Val_int(-32170429) -#define MLTAG_cull_face Val_int(-406215286) -#define MLTAG_depth_test Val_int(-917936050) -#define MLTAG_dither Val_int(1035927782) -#define MLTAG_fog Val_int(5097214) -#define MLTAG_light0 Val_int(-402511206) -#define MLTAG_light1 Val_int(-402511205) -#define MLTAG_light2 Val_int(-402511204) -#define MLTAG_light3 Val_int(-402511203) -#define MLTAG_light4 Val_int(-402511202) -#define MLTAG_light5 Val_int(-402511201) -#define MLTAG_light6 Val_int(-402511200) -#define MLTAG_light7 Val_int(-402511199) -#define MLTAG_lighting Val_int(218179020) -#define MLTAG_line_smooth Val_int(-421222311) -#define MLTAG_line_stipple Val_int(-101916010) -#define MLTAG_logic_op Val_int(245648546) -#define MLTAG_index_logic_op Val_int(-780749137) -#define MLTAG_color_logic_op Val_int(471076414) -#define MLTAG_map1_color_4 Val_int(-55552082) -#define MLTAG_map1_index Val_int(47668776) -#define MLTAG_map1_normal Val_int(370238033) -#define MLTAG_map1_texture_coord_1 Val_int(-54356775) -#define MLTAG_map1_texture_coord_2 Val_int(-54356774) -#define MLTAG_map1_texture_coord_3 Val_int(-54356773) -#define MLTAG_map1_texture_coord_4 Val_int(-54356772) -#define MLTAG_map1_vertex_3 Val_int(-81486334) -#define MLTAG_map1_vertex_4 Val_int(-81486333) -#define MLTAG_map2_color_4 Val_int(-811482961) -#define MLTAG_map2_index Val_int(745329897) -#define MLTAG_map2_normal Val_int(-817638288) -#define MLTAG_map2_texture_coord_1 Val_int(-4823334) -#define MLTAG_map2_texture_coord_2 Val_int(-4823333) -#define MLTAG_map2_texture_coord_3 Val_int(-4823332) -#define MLTAG_map2_texture_coord_4 Val_int(-4823331) -#define MLTAG_map2_vertex_3 Val_int(997135841) -#define MLTAG_map2_vertex_4 Val_int(997135842) -#define MLTAG_normalize Val_int(731985805) -#define MLTAG_point_smooth Val_int(120885117) -#define MLTAG_polygon_offset_fill Val_int(-923697814) -#define MLTAG_polygon_offset_line Val_int(-857159973) -#define MLTAG_polygon_offset_point Val_int(-799862903) -#define MLTAG_polygon_smooth Val_int(-295716205) -#define MLTAG_polygon_stipple Val_int(-31341796) -#define MLTAG_scissor_test Val_int(-835660139) -#define MLTAG_stencil_test Val_int(-901188427) -#define MLTAG_texture_1d Val_int(819344183) -#define MLTAG_texture_2d Val_int(819344406) -#define MLTAG_texture_gen_q Val_int(-339296738) -#define MLTAG_texture_gen_r Val_int(-339296737) -#define MLTAG_texture_gen_s Val_int(-339296736) -#define MLTAG_texture_gen_t Val_int(-339296735) -#define MLTAG_flat Val_int(-1010955335) -#define MLTAG_smooth Val_int(124454958) -#define MLTAG_ambient Val_int(159488024) -#define MLTAG_diffuse Val_int(947872098) -#define MLTAG_specular Val_int(325867203) -#define MLTAG_position Val_int(-889544535) -#define MLTAG_spot_direction Val_int(-893428862) -#define MLTAG_spot_exponent Val_int(-328656244) -#define MLTAG_spot_cutoff Val_int(347462154) -#define MLTAG_constant_attenuation Val_int(-904210993) -#define MLTAG_linear_attenuation Val_int(-122379312) -#define MLTAG_quadratic_attenuation Val_int(1060322627) -#define MLTAG_emission Val_int(-999569785) -#define MLTAG_shininess Val_int(-963291258) -#define MLTAG_ambient_and_diffuse Val_int(-832180525) -#define MLTAG_color_indexes Val_int(-1014447644) -#define MLTAG_never Val_int(422592140) -#define MLTAG_less Val_int(-944762023) -#define MLTAG_equal Val_int(-226308172) -#define MLTAG_lequal Val_int(554551240) -#define MLTAG_greater Val_int(935366906) -#define MLTAG_notequal Val_int(-278646335) -#define MLTAG_gequal Val_int(558168557) -#define MLTAG_always Val_int(-958984497) -#define MLTAG_zero Val_int(-789508312) -#define MLTAG_one Val_int(5544550) -#define MLTAG_dst_color Val_int(905171049) -#define MLTAG_one_minus_dst_color Val_int(-275037823) -#define MLTAG_src_alpha Val_int(-315369341) -#define MLTAG_one_minus_src_alpha Val_int(651905435) -#define MLTAG_dst_alpha Val_int(221120100) -#define MLTAG_one_minus_dst_alpha Val_int(-959088772) -#define MLTAG_src_alpha_saturate Val_int(-713439637) -#define MLTAG_src_color Val_int(368681608) -#define MLTAG_one_minus_src_color Val_int(-811527264) -#define MLTAG_linear Val_int(-325037595) -#define MLTAG_exp Val_int(5049501) -#define MLTAG_exp2 Val_int(-1021444875) -#define MLTAG_compile Val_int(57615731) -#define MLTAG_compile_and_execute Val_int(-605208191) -#define MLTAG_bitmap Val_int(-250867729) -#define MLTAG_byte Val_int(-1054662904) -#define MLTAG_short Val_int(-64519044) -#define MLTAG_int Val_int(5246191) -#define MLTAG_float Val_int(43435420) -#define MLTAG_double Val_int(852175633) -#define MLTAG_ubyte Val_int(520420861) -#define MLTAG_ushort Val_int(-1008157721) -#define MLTAG_uint Val_int(-844758118) -#define MLTAG_load Val_int(-944268762) -#define MLTAG_add Val_int(4846113) -#define MLTAG_mult Val_int(-932878352) -#define MLTAG_return Val_int(153986224) -#define MLTAG_color_index Val_int(1066401782) -#define MLTAG_stencil_index Val_int(-435403441) -#define MLTAG_depth_component Val_int(351461185) -#define MLTAG_rgb Val_int(5692173) -#define MLTAG_bgr Val_int(4896525) -#define MLTAG_rgba Val_int(-878128972) -#define MLTAG_bgra Val_int(-1055558476) -#define MLTAG_red Val_int(5691729) -#define MLTAG_green Val_int(434966211) -#define MLTAG_blue Val_int(-1055309158) -#define MLTAG_alpha Val_int(563521374) -#define MLTAG_luminance Val_int(-393725960) -#define MLTAG_luminance_alpha Val_int(22311063) -#define MLTAG_dont_care Val_int(-409560193) -#define MLTAG_fastest Val_int(-566636758) -#define MLTAG_nicest Val_int(840024446) -#define MLTAG_clear Val_int(-933531251) -#define MLTAG_set Val_int(5741474) -#define MLTAG_copy Val_int(-1044071499) -#define MLTAG_copy_inverted Val_int(-54899201) -#define MLTAG_noop Val_int(-922086494) -#define MLTAG_invert Val_int(534308630) -#define MLTAG_And Val_int(3257015) -#define MLTAG_nand Val_int(-922782935) -#define MLTAG_Or Val_int(17731) -#define MLTAG_nor Val_int(5495057) -#define MLTAG_xor Val_int(5992347) -#define MLTAG_equiv Val_int(-226306378) -#define MLTAG_and_reverse Val_int(793230458) -#define MLTAG_and_inverted Val_int(586750621) -#define MLTAG_or_reverse Val_int(612323014) -#define MLTAG_or_inverted Val_int(1046579921) -#define MLTAG_alpha_bias Val_int(27257402) -#define MLTAG_alpha_scale Val_int(807770025) -#define MLTAG_blue_bias Val_int(959780222) -#define MLTAG_blue_scale Val_int(454445029) -#define MLTAG_depth_bias Val_int(1030130293) -#define MLTAG_depth_scale Val_int(-1037358322) -#define MLTAG_green_bias Val_int(901747893) -#define MLTAG_green_scale Val_int(398137550) -#define MLTAG_index_offset Val_int(-876120992) -#define MLTAG_index_shift Val_int(-393779115) -#define MLTAG_map_color Val_int(-191979456) -#define MLTAG_map_stencil Val_int(1044717081) -#define MLTAG_red_bias Val_int(-800667801) -#define MLTAG_red_scale Val_int(864043484) -#define MLTAG_i_to_i Val_int(-74757061) -#define MLTAG_i_to_r Val_int(-74757052) -#define MLTAG_i_to_g Val_int(-74757063) -#define MLTAG_i_to_b Val_int(-74757068) -#define MLTAG_i_to_a Val_int(-74757069) -#define MLTAG_s_to_s Val_int(-81991685) -#define MLTAG_r_to_r Val_int(348228507) -#define MLTAG_g_to_g Val_int(785683323) -#define MLTAG_b_to_b Val_int(789300635) -#define MLTAG_a_to_a Val_int(-927962821) -#define MLTAG_pack_swap_bytes Val_int(1064029541) -#define MLTAG_pack_lsb_first Val_int(-693993082) -#define MLTAG_pack_row_length Val_int(-192463215) -#define MLTAG_pack_skip_pixels Val_int(942681735) -#define MLTAG_pack_skip_rows Val_int(1056098803) -#define MLTAG_pack_alignment Val_int(698523325) -#define MLTAG_unpack_swap_bytes Val_int(797733676) -#define MLTAG_unpack_lsb_first Val_int(-473697889) -#define MLTAG_unpack_row_length Val_int(-458759080) -#define MLTAG_unpack_skip_pixels Val_int(-459237664) -#define MLTAG_unpack_skip_rows Val_int(-871089652) -#define MLTAG_unpack_alignment Val_int(918818518) -#define MLTAG_front_left Val_int(342623901) -#define MLTAG_front_right Val_int(-1054420858) -#define MLTAG_back_left Val_int(-1002103713) -#define MLTAG_back_right Val_int(-280968060) -#define MLTAG_left Val_int(-944764921) -#define MLTAG_right Val_int(-379319332) -#define MLTAG_none Val_int(-922086728) -#define MLTAG_keep Val_int(-955854715) -#define MLTAG_replace Val_int(724060212) -#define MLTAG_incr Val_int(-977586732) -#define MLTAG_decr Val_int(-1033482128) -#define MLTAG_modulate Val_int(59249689) -#define MLTAG_decal Val_int(-685767891) -#define MLTAG_s Val_int(115) -#define MLTAG_t Val_int(116) -#define MLTAG_r Val_int(114) -#define MLTAG_q Val_int(113) -#define MLTAG_object_plane Val_int(-437592676) -#define MLTAG_eye_plane Val_int(-360481330) -#define MLTAG_eye_linear Val_int(-42314189) -#define MLTAG_object_linear Val_int(-58275163) -#define MLTAG_sphere_map Val_int(-892466902) -#define MLTAG_min_filter Val_int(-334342651) -#define MLTAG_mag_filter Val_int(-1004146908) -#define MLTAG_wrap_s Val_int(-124185730) -#define MLTAG_wrap_t Val_int(-124185729) -#define MLTAG_border_color Val_int(-286753136) -#define MLTAG_priority Val_int(993950564) -#define MLTAG_nearest Val_int(-439740322) -#define MLTAG_nearest_mipmap_nearest Val_int(99332456) -#define MLTAG_linear_mipmap_nearest Val_int(-480032831) -#define MLTAG_nearest_mipmap_linear Val_int(-149280741) -#define MLTAG_linear_mipmap_linear Val_int(531849186) -#define MLTAG_generate_mipmap Val_int(-785096558) -#define MLTAG_clamp Val_int(-933727493) -#define MLTAG_repeat Val_int(108828507) -#define MLTAG_vendor Val_int(513205640) -#define MLTAG_renderer Val_int(853263683) -#define MLTAG_version Val_int(-51255528) -#define MLTAG_extensions Val_int(158366740) -#define MLTAG_render Val_int(86600534) -#define MLTAG_select Val_int(-365749508) -#define MLTAG_feedback Val_int(-381706107) -#define MLTAG__2d Val_int(4735505) -#define MLTAG__3d Val_int(4735728) -#define MLTAG__3d_color Val_int(826855316) -#define MLTAG__3d_color_texture Val_int(962176496) -#define MLTAG__4d_color_texture Val_int(9031439) -#define MLTAG_local_viewer Val_int(-578565722) -#define MLTAG_two_side Val_int(542613610) -#define MLTAG_mode Val_int(-933178525) -#define MLTAG_density Val_int(-1026211864) -#define MLTAG_start Val_int(67859554) -#define MLTAG_index Val_int(1041537810) -#define MLTAG_End Val_int(3455931) -#define MLTAG_color_control Val_int(-62205631) -#define MLTAG_separate_specular_color Val_int(332198979) -#define MLTAG_single_color Val_int(853325100) -#define MLTAG_perspective_correction Val_int(-617388863) -#define MLTAG_vertex_3 Val_int(-410988712) -#define MLTAG_vertex_4 Val_int(-410988711) -#define MLTAG_color_4 Val_int(-278519016) -#define MLTAG_normal Val_int(812216871) -#define MLTAG_texture_coord_1 Val_int(-223290813) -#define MLTAG_texture_coord_2 Val_int(-223290812) -#define MLTAG_texture_coord_3 Val_int(-223290811) -#define MLTAG_texture_coord_4 Val_int(-223290810) -#define MLTAG_accum_buffer Val_int(506708454) -#define MLTAG_color_buffer Val_int(454139804) -#define MLTAG_current Val_int(-874275783) -#define MLTAG_depth_buffer Val_int(940135420) -#define MLTAG_enable Val_int(-125325693) -#define MLTAG_eval Val_int(-1021547620) -#define MLTAG_hint Val_int(-988922489) -#define MLTAG_list Val_int(-944563106) -#define MLTAG_pixel_mode Val_int(120767228) -#define MLTAG_scissor Val_int(82257948) -#define MLTAG_stencil_buffer Val_int(559024163) -#define MLTAG_transform Val_int(-980210324) -#define MLTAG_viewport Val_int(480595046) -#define MLTAG_aux Val_int(4849924) -#define MLTAG_edge_flag Val_int(619733550) -#define MLTAG_texture_coord Val_int(617177361) -#define MLTAG_vertex Val_int(558357348) -#define MLTAG_two Val_int(5795212) -#define MLTAG_three Val_int(261117022) -#define MLTAG_four Val_int(-1010801690) -#define MLTAG_no_error Val_int(176986634) -#define MLTAG_invalid_enum Val_int(139431049) -#define MLTAG_invalid_value Val_int(-25381655) -#define MLTAG_invalid_operation Val_int(-203893345) -#define MLTAG_stack_overflow Val_int(915622489) -#define MLTAG_stack_underflow Val_int(989782543) -#define MLTAG_out_of_memory Val_int(1062958648) -#define MLTAG_table_too_large Val_int(1060772319) -#define MLTAG_vertex_shader Val_int(814082528) -#define MLTAG_fragment_shader Val_int(-978777356) diff --git a/lablGL/ml_gl.c b/lablGL/ml_gl.c deleted file mode 100644 index 4e88ab1..0000000 --- a/lablGL/ml_gl.c +++ /dev/null @@ -1,728 +0,0 @@ -/* $Id: ml_gl.c,v 1.51 2007-04-13 02:48:43 garrigue Exp $ */ - -#ifdef _WIN32 -#include -#endif -#include -#ifdef __APPLE__ -#include -#else -#include -#endif -#ifdef HAS_GLEXT_H -#include -#undef GL_VERSION_1_3 -#endif -#include -#include -#include -#include -#include -#include -#include "ml_raw.h" -#include "gl_tags.h" -#include "ml_gl.h" - -#if !defined(GL_VERSION_1_4) -#define GL_GENERATE_MIPMAP 0x8191 -#endif - -void ml_raise_gl(const char *errmsg) -{ - static value const * gl_exn; - if (gl_exn == NULL) - gl_exn = caml_named_value("glerror"); - caml_raise_with_string(*gl_exn, (char*)errmsg); -} - -value copy_string_check (const char *str) -{ - if (!str) ml_raise_gl("Null string"); - return caml_copy_string ((char*) str); -} - -struct record { - value key; - GLenum data; -}; - -static struct record input_table[] = { -#include "gl_tags.c" -}; - -static struct record *tag_table = NULL; - -#define TABLE_SIZE (TAG_NUMBER*2+1) - -CAMLprim value ml_gl_make_table (value unit) -{ - int i; - unsigned int hash; - - tag_table = caml_stat_alloc (TABLE_SIZE * sizeof(struct record)); - memset ((char *) tag_table, 0, TABLE_SIZE * sizeof(struct record)); - for (i = 0; i < TAG_NUMBER; i++) { - hash = (unsigned long) input_table[i].key % TABLE_SIZE; - while (tag_table[hash].key != 0) { - hash ++; - if (hash == TABLE_SIZE) hash = 0; - } - tag_table[hash].key = input_table[i].key; - tag_table[hash].data = input_table[i].data; - } - return Val_unit; -} - -GLenum GLenum_val(value tag) -{ - unsigned int hash = (unsigned long) tag % TABLE_SIZE; - - if (!tag_table) ml_gl_make_table (Val_unit); - while (tag_table[hash].key != tag) { - if (tag_table[hash].key == 0) ml_raise_gl ("Unknown tag"); - hash++; - if (hash == TABLE_SIZE) hash = 0; - } - /* - fprintf(stderr, "Converted %ld to %d", Int_val(tag), tag_table[hash].data); - */ - return tag_table[hash].data; -} - -/* -GLenum GLenum_val(value tag) -{ - switch(tag) - { -#include "gl_tags.c" - } - ml_raise_gl("Unknown tag"); -} -*/ - -ML_2 (glAccum, GLenum_val, Float_val) -ML_2 (glAlphaFunc, GLenum_val, Float_val) - -ML_1 (glBegin, GLenum_val) - -ML_5 (glBitmap, Int_val, Int_val, Pair(arg3,Float_val,Float_val), - Pair(arg4,Float_val,Float_val), Void_raw) - -ML_2 (glBlendFunc, GLenum_val, GLenum_val) - -CAMLprim value ml_glClipPlane(value plane, value equation) /* ML */ -{ - double eq[4]; - int i; - - for (i = 0; i < 4; i++) - eq[i] = Double_val (Field(equation,i)); - glClipPlane (GL_CLIP_PLANE0 + Int_val(plane), eq); - return Val_unit; -} - -CAMLprim value ml_glClear(value bit_list) /* ML */ -{ - GLbitfield accu = 0; - - while (bit_list != Val_int(0)) { - switch (Field (bit_list, 0)) { - case MLTAG_color: - accu |= GL_COLOR_BUFFER_BIT; break; - case MLTAG_depth: - accu |= GL_DEPTH_BUFFER_BIT; break; - case MLTAG_accum: - accu |= GL_ACCUM_BUFFER_BIT; break; - case MLTAG_stencil: - accu |= GL_STENCIL_BUFFER_BIT; break; - } - bit_list = Field (bit_list, 1); - } - glClear (accu); - return Val_unit; -} -ML_4 (glClearAccum, Float_val, Float_val, Float_val, Float_val) -ML_4 (glClearColor, Double_val, Double_val, Double_val, Double_val) -ML_1 (glClearDepth, Double_val) -ML_1 (glClearIndex, Float_val) -ML_1 (glClearStencil, Int_val) -ML_4 (glColor4d, Double_val, Double_val, Double_val, Double_val) -ML_4 (glColorMask, Int_val, Int_val, Int_val, Int_val) -ML_2 (glColorMaterial, GLenum_val, GLenum_val) -ML_5 (glCopyPixels, Int_val, Int_val, Int_val, Int_val, GLenum_val) -ML_1 (glCullFace, GLenum_val) - -ML_1 (glDisable, GLenum_val) -ML_1 (glDepthFunc, GLenum_val) -ML_1 (glDepthMask, Int_val) -ML_2 (glDepthRange, Double_val, Double_val) - -CAMLprim value ml_glDrawBuffer (value buffer) -{ - if (Is_block(buffer)) { - int n = Int_val (Field(buffer,1)); - if (n >= GL_AUX_BUFFERS) - ml_raise_gl ("GlFunc.draw_buffer : no such auxiliary buffer"); - glDrawBuffer (GL_AUX0 + n); - } - else glDrawBuffer (GLenum_val(buffer)); - return Val_unit; -} - -ML_4 (glDrawPixels, Int_val, Int_val, GLenum_val, Type_void_raw) - -ML_1 (glEdgeFlag, Int_val) -ML_1 (glEnable, GLenum_val) -ML_0 (glEnd) -ML_1 (glEvalCoord1d, Double_val) -ML_2 (glEvalCoord2d, Double_val, Double_val) -ML_3 (glEvalMesh1, GLenum_val, Int_val, Int_val) -ML_5 (glEvalMesh2, GLenum_val, Int_val, Int_val, Int_val, Int_val) -ML_1 (glEvalPoint1, Int_val) -ML_2 (glEvalPoint2, Int_val, Int_val) - - -ML_3 (glFeedbackBuffer, Int_val, GLenum_val, (GLfloat*)Addr_raw) - -CAMLprim value ml_glFog (value param) /* ML */ -{ - float params[4]; - int i; - - switch (Field(param,0)) - { - case MLTAG_mode: - glFogi(GL_FOG_MODE, GLenum_val(Field(param,1))); - break; - case MLTAG_density: - glFogf(GL_FOG_DENSITY, Float_val(Field(param,1))); - break; - case MLTAG_start: - glFogf(GL_FOG_START, Float_val(Field(param,1))); - break; - case MLTAG_End: - glFogf(GL_FOG_END, Float_val(Field(param,1))); - break; - case MLTAG_index: - glFogf(GL_FOG_INDEX, Float_val(Field(param,1))); - break; - case MLTAG_color: - for (i = 0; i < 4; i++) params[i] = Float_val(Field(Field(param,1),i)); - glFogfv(GL_FOG_COLOR, params); - break; - } - return Val_unit; -} - -ML_0 (glFlush) -ML_0 (glFinish) -ML_1 (glFrontFace, GLenum_val) -ML_3 (glFrustum, Pair(arg1,Double_val,Double_val), - Pair(arg2,Double_val,Double_val), Pair(arg3,Double_val,Double_val)) - -ML_1_ (glGetString, GLenum_val, copy_string_check) -ML_2 (glGetDoublev, GLenum_val, Double_raw) - -CAMLprim value ml_glGetError(value unit) -{ - switch (glGetError()) { - case GL_NO_ERROR: return MLTAG_no_error; - case GL_INVALID_ENUM: return MLTAG_invalid_enum; - case GL_INVALID_VALUE: return MLTAG_invalid_value; - case GL_INVALID_OPERATION: return MLTAG_invalid_operation; - case GL_STACK_OVERFLOW: return MLTAG_stack_overflow; - case GL_STACK_UNDERFLOW: return MLTAG_stack_underflow; - case GL_OUT_OF_MEMORY: return MLTAG_out_of_memory; -#if defined(GL_VERSION_1_2) || defined(GL_TABLE_TOO_LARGE) - case GL_TABLE_TOO_LARGE: return MLTAG_table_too_large; -#endif - default: ml_raise_gl("glGetError: unknown error"); - } -} - -CAMLprim value ml_glHint (value target, value hint) -{ - GLenum targ = 0U; - - switch (target) { - case MLTAG_fog: targ = GL_FOG_HINT; break; - case MLTAG_line_smooth: targ = GL_LINE_SMOOTH_HINT; break; - case MLTAG_perspective_correction: - targ = GL_PERSPECTIVE_CORRECTION_HINT; break; - case MLTAG_point_smooth: targ = GL_POINT_SMOOTH_HINT; break; - case MLTAG_polygon_smooth: targ = GL_POLYGON_SMOOTH_HINT; break; - } - glHint (targ, GLenum_val(hint)); - return Val_unit; -} - -ML_1 (glIndexMask, Int_val) -ML_1 (glIndexd, Double_val) -ML_0 (glInitNames) -ML_1_ (glIsEnabled, GLenum_val, Val_int) - -CAMLprim value ml_glLight (value n, value param) /* ML */ -{ - float params[4]; - int i; - - if (Int_val(n) >= GL_MAX_LIGHTS) caml_invalid_argument ("Gl.light"); - switch (Field(param,0)) - { - case MLTAG_ambient: - case MLTAG_diffuse: - case MLTAG_specular: - case MLTAG_position: - for (i = 0; i < 4; i++) - params[i] = Float_val (Field(Field(param, 1), i)); - break; - case MLTAG_spot_direction: - for (i = 0; i < 3; i++) - params[i] = Float_val (Field(Field(param, 1), i)); - break; - default: - params[0] = Float_val (Field(param, 1)); - } - glLightfv (GL_LIGHT0 + Int_val(n), GLenum_val(Field(param,0)), params); - return Val_unit; -} - -CAMLprim value ml_glLightModel (value param) /* ML */ -{ - float params[4]; - int i; - - switch (Field(param,0)) - { - case MLTAG_ambient: - for (i = 0; i < 4; i++) - params[i] = Float_val (Field(Field(param,1),i)); - glLightModelfv (GL_LIGHT_MODEL_AMBIENT, params); - break; - case MLTAG_local_viewer: - glLightModelf (GL_LIGHT_MODEL_LOCAL_VIEWER, - Int_val(Field(param,1))); - break; - case MLTAG_two_side: - glLightModeli (GL_LIGHT_MODEL_TWO_SIDE, - Int_val(Field(param,1))); - break; - case MLTAG_color_control: -#ifdef GL_VERSION_1_2 - switch (Field(param,1)) - { - case MLTAG_separate_specular_color: - glLightModeli (GL_LIGHT_MODEL_COLOR_CONTROL, - GL_SEPARATE_SPECULAR_COLOR); - break; - case MLTAG_single_color: - glLightModeli (GL_LIGHT_MODEL_COLOR_CONTROL, - GL_SINGLE_COLOR); - break; - } -#else - ml_raise_gl ("Parameter: GL_LIGHT_MODEL_COLOR_CONTROL not available"); -#endif - break; - } - return Val_unit; -} - -ML_1 (glLineWidth, Float_val) -ML_2 (glLineStipple, Int_val, Int_val) -ML_1 (glLoadName, Int_val) -ML_0 (glLoadIdentity) -ML_1 (glLoadMatrixd, Double_raw) - -#ifdef GL_VERSION_1_3 -ML_1 (glLoadTransposeMatrixd, Double_raw) -#else -CAMLprim void ml_glLoadTransposeMatrixd (value raw) -{ - ml_raise_gl ("Function: glLoadTransposeMatrixd not available"); -} -#endif -ML_1 (glLogicOp, GLenum_val) - -CAMLprim value ml_glMap1d (value target, value *u, value order, value raw) -{ - int ustride = 0; - GLenum targ = 0U; - - switch (target) { - case MLTAG_vertex_3: - targ = GL_MAP1_VERTEX_3; ustride = 3; break; - case MLTAG_vertex_4: - targ = GL_MAP1_VERTEX_4; ustride = 4; break; - case MLTAG_index: - targ = GL_MAP1_INDEX; ustride = 1; break; - case MLTAG_color_4: - targ = GL_MAP1_COLOR_4; ustride = 4; break; - case MLTAG_normal: - targ = GL_MAP1_NORMAL; ustride = 3; break; - case MLTAG_texture_coord_1: - targ = GL_MAP1_TEXTURE_COORD_1; ustride = 1; break; - case MLTAG_texture_coord_2: - targ = GL_MAP1_TEXTURE_COORD_2; ustride = 2; break; - case MLTAG_texture_coord_3: - targ = GL_MAP1_TEXTURE_COORD_3; ustride = 3; break; - case MLTAG_texture_coord_4: - targ = GL_MAP1_TEXTURE_COORD_4; ustride = 4; break; - } - glMap1d (targ, Double_val(u[0]), Double_val(u[1]), - ustride, Int_val(order), Double_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glMap2d (value target, value u, value uorder, - value v, value vorder, value raw) -{ - int ustride = 0; - GLenum targ = 0U; - - switch (target) { - case MLTAG_vertex_3: - targ = GL_MAP2_VERTEX_3; ustride = 3; break; - case MLTAG_vertex_4: - targ = GL_MAP2_VERTEX_4; ustride = 4; break; - case MLTAG_index: - targ = GL_MAP2_INDEX; ustride = 1; break; - case MLTAG_color_4: - targ = GL_MAP2_COLOR_4; ustride = 4; break; - case MLTAG_normal: - targ = GL_MAP2_NORMAL; ustride = 3; break; - case MLTAG_texture_coord_1: - targ = GL_MAP2_TEXTURE_COORD_1; ustride = 1; break; - case MLTAG_texture_coord_2: - targ = GL_MAP2_TEXTURE_COORD_2; ustride = 2; break; - case MLTAG_texture_coord_3: - targ = GL_MAP2_TEXTURE_COORD_3; ustride = 3; break; - case MLTAG_texture_coord_4: - targ = GL_MAP2_TEXTURE_COORD_4; ustride = 4; break; - } - glMap2d (targ, Double_val(Field(u,0)), Double_val(Field(u,1)), ustride, - Int_val(uorder), Double_val(Field(v,0)), Double_val(Field(v,1)), - Int_val(uorder)*ustride, Int_val(vorder), Double_raw(raw)); - return Val_unit; -} - -ML_bc6 (ml_glMap2d) - -ML_2 (glMapGrid1d, Int_val, Pair(arg2,Double_val,Double_val)) -ML_4 (glMapGrid2d, Int_val, Pair(arg2,Double_val,Double_val), - Int_val, Pair(arg4,Double_val,Double_val)) - -CAMLprim value ml_glMaterial (value face, value param) /* ML */ -{ - float params[4]; - int i; - - switch (Field(param,0)) - { - case MLTAG_shininess: - params[0] = Float_val (Field(param, 1)); - break; - case MLTAG_color_indexes: - for (i = 0; i < 3; i++) - params[i] = Float_val (Field(Field(param, 1), i)); - break; - default: - for (i = 0; i < 4; i++) - params[i] = Float_val (Field(Field(param, 1), i)); - break; - } - glMaterialfv (GLenum_val(face), GLenum_val(Field(param,0)), params); - return Val_unit; -} - -ML_1 (glMatrixMode, GLenum_val) -ML_1 (glMultMatrixd, Double_raw) - -#ifdef GL_VERSION_1_3 -ML_1 (glMultTransposeMatrixd, Double_raw) -#else -CAMLprim void ml_glMultTransposeMatrixd (value raw) -{ - ml_raise_gl ("Function: glMultTransposeMatrixd not available"); -} -#endif - -ML_3 (glNormal3d, Double_val, Double_val, Double_val) - -ML_1 (glPassThrough, Float_val) - -CAMLprim value ml_glPixelMapfv (value map, value raw) -{ - glPixelMapfv (GLenum_val(map), Int_val(Size_raw(raw))/sizeof(GLfloat), - Float_raw(raw)); - return Val_unit; -} - -ML_3 (glOrtho, Pair(arg1,Double_val,Double_val), - Pair(arg2,Double_val,Double_val), Pair(arg3,Double_val,Double_val)) - -ML_1 (glPixelStorei, Pair(arg1,GLenum_val,Int_val)) - -CAMLprim value ml_glPixelTransfer (value param) -{ - GLenum pname = GLenum_val (Field(param,0)); - - switch (pname) { - case GL_MAP_COLOR: - case GL_MAP_STENCIL: - case GL_INDEX_SHIFT: - case GL_INDEX_OFFSET: - glPixelTransferi (pname, Int_val (Field(param,1))); - break; - default: - glPixelTransferf (pname, Float_val (Field(param,1))); - } - return Val_unit; -} - -ML_2 (glPixelZoom, Float_val, Float_val) -ML_1 (glPointSize, Float_val) -ML_2 (glPolygonOffset, Float_val, Float_val) -ML_2 (glPolygonMode, GLenum_val, GLenum_val) -ML_1 (glPolygonStipple, (unsigned char *)Byte_raw) -ML_0 (glPopAttrib) -ML_0 (glPopMatrix) -ML_0 (glPopName) - -CAMLprim value ml_glPushAttrib (value list) -{ - GLbitfield mask = 0; - - while (list != Val_int(0)) { - switch (Field(list,0)) { - case MLTAG_accum_buffer:mask |= GL_ACCUM_BUFFER_BIT; break; - case MLTAG_color_buffer:mask |= GL_COLOR_BUFFER_BIT; break; - case MLTAG_current: mask |= GL_CURRENT_BIT; break; - case MLTAG_depth_buffer:mask |= GL_DEPTH_BUFFER_BIT; break; - case MLTAG_enable: mask |= GL_ENABLE_BIT; break; - case MLTAG_eval: mask |= GL_EVAL_BIT; break; - case MLTAG_fog: mask |= GL_FOG_BIT; break; - case MLTAG_hint: mask |= GL_HINT_BIT; break; - case MLTAG_lighting: mask |= GL_LIGHTING_BIT; break; - case MLTAG_line: mask |= GL_LINE_BIT; break; - case MLTAG_list: mask |= GL_LIST_BIT; break; - case MLTAG_pixel_mode: mask |= GL_PIXEL_MODE_BIT; break; - case MLTAG_point: mask |= GL_POINT_BIT; break; - case MLTAG_polygon: mask |= GL_POLYGON_BIT; break; - case MLTAG_polygon_stipple:mask |= GL_POLYGON_STIPPLE_BIT; break; - case MLTAG_scissor: mask |= GL_SCISSOR_BIT; break; - case MLTAG_stencil_buffer:mask |= GL_STENCIL_BUFFER_BIT; break; - case MLTAG_texture: mask |= GL_TEXTURE_BIT; break; - case MLTAG_transform: mask |= GL_TRANSFORM_BIT; break; - case MLTAG_viewport: mask |= GL_VIEWPORT_BIT; break; - } - list = Field(list,1); - } - glPushAttrib (mask); - return Val_unit; -} - -ML_0 (glPushMatrix) -ML_1 (glPushName, Int_val) - -CAMLprim value ml_glRasterPos(value x, value y, value z, value w) /* ML */ -{ - if (z == Val_int(0)) glRasterPos2d (Double_val(x), Double_val(y)); - else if (w == Val_int(0)) - glRasterPos3d (Double_val(x), Double_val(y), Double_val(Field(z, 0))); - else - glRasterPos4d (Double_val(x), Double_val(y), Double_val(Field(z, 0)), - Double_val(Field(w, 0))); - return Val_unit; -} - -CAMLprim value ml_glReadBuffer (value buffer) -{ - if (Is_block(buffer)) { - int n = Int_val (Field(buffer,1)); - if (n >= GL_AUX_BUFFERS) - ml_raise_gl ("GlFunc.read_buffer : no such auxiliary buffer"); - glReadBuffer (GL_AUX0 + n); - } - else glReadBuffer (GLenum_val(buffer)); - return Val_unit; -} - -CAMLprim value ml_glReadPixels(value x, value y, value w, value h, value format , value raw) /* ML */ -{ - glPixelStorei(GL_PACK_SWAP_BYTES, 0); - glPixelStorei(GL_PACK_ALIGNMENT, 1); - glReadPixels(Int_val(x),Int_val(y),Int_val(w),Int_val(h),GLenum_val(format), - Type_void_raw(raw)); - return Val_unit; -} - -ML_bc6 (ml_glReadPixels) -ML_2 (glRectd, Pair(arg1,Double_val,Double_val), - Pair(arg2,Double_val,Double_val)) -ML_1_ (glRenderMode, GLenum_val, Val_int) -ML_4 (glRotated, Double_val, Double_val, Double_val, Double_val) -ML_3 (glScaled, Double_val, Double_val, Double_val) - -ML_4 (glScissor, Int_val, Int_val, Int_val, Int_val) -ML_2 (glSelectBuffer, Int_val, (GLuint*)Addr_raw) -ML_1 (glShadeModel, GLenum_val) -ML_3 (glStencilFunc, GLenum_val, Int_val, Int_val) -ML_1 (glStencilMask, Int_val) -ML_3 (glStencilOp, GLenum_val, GLenum_val, GLenum_val) - -ML_1 (glTexCoord1d, Double_val) -ML_2 (glTexCoord2d, Double_val, Double_val) -ML_3 (glTexCoord3d, Double_val, Double_val, Double_val) -ML_4 (glTexCoord4d, Double_val, Double_val, Double_val, Double_val) - -CAMLprim value ml_glTexEnv (value param) -{ - value params = Field(param,1); - GLfloat color[4]; - int i; - - switch (Field(param,0)) { - case MLTAG_mode: - glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GLenum_val(params)); - break; - case MLTAG_color: - for (i = 0; i < 4; i++) color[i] = Float_val(Field(params,i)); - glTexEnvfv (GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, color); - break; - } - return Val_unit; -} - -CAMLprim value ml_glTexGen (value coord, value param) -{ - value params = Field(param,1); - GLdouble point[4]; - int i; - - if (Field(param,0) == MLTAG_mode) - glTexGeni (GLenum_val(coord), GL_TEXTURE_GEN_MODE, GLenum_val(params)); - else { - for (i = 0; i < 4; i++) point[i] = Double_val(Field(params,i)); - glTexGendv (GLenum_val(coord), GLenum_val(Field(param,0)), point); - } - return Val_unit; -} - -CAMLprim value ml_glTexImage1D (value proxy, value level, value internal, - value width, value border, value format, - value data) -{ - glTexImage1D (proxy == Val_int(1) - ? GL_PROXY_TEXTURE_1D : GL_TEXTURE_1D, - Int_val(level), Int_val(internal), Int_val(width), - Int_val(border), GLenum_val(format), - Type_raw(data), Void_raw(data)); - return Val_unit; -} - -ML_bc7 (ml_glTexImage1D) - -CAMLprim value ml_glTexImage2D (value proxy, value level, value internal, - value width, value height, value border, - value format, value data) -{ - /* printf("p=%x,l=%d,i=%d,w=%d,h=%d,b=%d,f=%x,t=%x,d=%x\n", */ - glTexImage2D (proxy == Val_int(1) - ? GL_PROXY_TEXTURE_2D : GL_TEXTURE_2D, - Int_val(level), Int_val(internal), Int_val(width), - Int_val(height), Int_val(border), GLenum_val(format), - Type_raw(data), Void_raw(data)); - /* flush(stdout); */ - return Val_unit; -} - -ML_bc8 (ml_glTexImage2D) - -CAMLprim value ml_glTexParameter (value target, value param) -{ - GLenum targ = GLenum_val(target); - GLenum pname = GLenum_val(Field(param,0)); - value params = Field(param,1); - GLfloat color[4]; - int i; - - switch (pname) { - case GL_TEXTURE_BORDER_COLOR: - for (i = 0; i < 4; i++) color[i] = Float_val(Field(params,i)); - glTexParameterfv (targ, pname, color); - break; - case GL_TEXTURE_PRIORITY: - glTexParameterf (targ, pname, Float_val(params)); - break; - case GL_GENERATE_MIPMAP: -#ifdef GL_VERSION_1_4 - glTexParameteri (targ, pname, Int_val(params)); -#else - ml_raise_gl ("Parameter: GL_GENERATE_MIPMAP not available"); -#endif - break; - default: - glTexParameteri (targ, pname, GLenum_val(params)); - break; - } - return Val_unit; -} - -ML_2 (glGenTextures, Int_val, Int_raw) -ML_2 (glBindTexture, GLenum_val, Nativeint_val) - -CAMLprim value ml_glDeleteTexture (value texture_id) -{ - GLuint id = Nativeint_val(texture_id); - glDeleteTextures(1,&id); - return Val_unit; -} - -ML_3 (glTranslated, Double_val, Double_val, Double_val) - -CAMLprim value ml_glVertex(value x, value y, value z, value w) /* ML */ -{ - if (z == Val_int(0)) glVertex2d (Double_val(x), Double_val(y)); - else if (w == Val_int(0)) - glVertex3d (Double_val(x), Double_val(y), Double_val(Field(z, 0))); - else - glVertex4d (Double_val(x), Double_val(y), Double_val(Field(z, 0)), - Double_val(Field(w, 0))); - return Val_unit; -} - -ML_4 (glViewport, Int_val, Int_val, Int_val, Int_val) - - -/* List functions */ - -ML_1_ (glIsList, Int_val, Val_int) -ML_2 (glDeleteLists, Int_val, Int_val) -ML_1_ (glGenLists, Int_val, Val_int) -ML_2 (glNewList, Int_val, GLenum_val) -ML_0 (glEndList) -ML_1 (glCallList, Int_val) -ML_1 (glListBase, Int_val) - -CAMLprim value ml_glCallLists (value indexes) /* ML */ -{ - int len,i; - int * table; - - switch (Field(indexes,0)) { - case MLTAG_byte: - glCallLists (caml_string_length(Field(indexes,1)), - GL_UNSIGNED_BYTE, - String_val(Field(indexes,1))); - break; - case MLTAG_int: - len = Wosize_val (indexes); - table = calloc (len, sizeof (GLint)); - for (i = 0; i < len; i++) table[i] = Int_val (Field(indexes,i)); - glCallLists (len, GL_INT, table); - free (table); - break; - } - return Val_unit; -} diff --git a/lablGL/ml_gl.h b/lablGL/ml_gl.h deleted file mode 100644 index 8053cf4..0000000 --- a/lablGL/ml_gl.h +++ /dev/null @@ -1,133 +0,0 @@ -/* $Id: ml_gl.h,v 1.21 2003-10-03 04:27:19 garrigue Exp $ */ - -#ifndef _ml_gl_ -#define _ml_gl_ - -#include "ml_raw.h" - -void ml_raise_gl (const char *errmsg) Noreturn; -#define copy_string_check lablgl_copy_string_check -value copy_string_check (const char *str); - -GLenum GLenum_val (value); - -#define Float_val(dbl) ((GLfloat) Double_val(dbl)) -#define Addr_val(addr) ((GLvoid *) addr) -#define Val_addr(addr) ((value) addr) -#define Type_raw(raw) (GLenum_val(Kind_raw(raw))) -#define Type_void_raw(raw) Type_raw(raw), Void_raw(raw) - -#define ML_0(cname) \ -CAMLprim value ml_##cname (value unit) \ -{ cname (); return Val_unit; } -#define ML_1(cname, conv1) \ -CAMLprim value ml_##cname (value arg1) \ -{ cname (conv1(arg1)); return Val_unit; } -#define ML_2(cname, conv1, conv2) \ -CAMLprim value ml_##cname (value arg1, value arg2) \ -{ cname (conv1(arg1), conv2(arg2)); return Val_unit; } -#define ML_3(cname, conv1, conv2, conv3) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3) \ -{ cname (conv1(arg1), conv2(arg2), conv3(arg3)); return Val_unit; } -#define ML_4(cname, conv1, conv2, conv3, conv4) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4) \ -{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4)); \ - return Val_unit; } -#define ML_5(cname, conv1, conv2, conv3, conv4, conv5) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5) \ -{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5)); \ - return Val_unit; } -#define ML_6(cname, conv1, conv2, conv3, conv4, conv5, conv6) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5, value arg6) \ -{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ - conv6(arg6)); \ - return Val_unit; } -#define ML_7(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5, value arg6, value arg7) \ -{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ - conv6(arg6), conv7(arg7)); \ - return Val_unit; } -#define ML_8(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5, value arg6, value arg7, value arg8) \ -{ cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), conv5(arg5), \ - conv6(arg6), conv7(arg7), conv8(arg8)); \ - return Val_unit; } - -#define ML_0_(cname, conv) \ -CAMLprim value ml_##cname (value unit) \ -{ return conv (cname ()); } -#define ML_1_(cname, conv1, conv) \ -CAMLprim value ml_##cname (value arg1) \ -{ return conv (cname (conv1(arg1))); } -#define ML_2_(cname, conv1, conv2, conv) \ -CAMLprim value ml_##cname (value arg1, value arg2) \ -{ return conv (cname (conv1(arg1), conv2(arg2))); } -#define ML_3_(cname, conv1, conv2, conv3, conv) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3) \ -{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); } -#define ML_4_(cname, conv1, conv2, conv3, conv4, conv) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4) \ -{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); } -#define ML_5_(cname, conv1, conv2, conv3, conv4, conv5, conv) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5) \ -{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ - conv5(arg5))); } -#define ML_6_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5, value arg6) \ -{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ - conv5(arg5), conv6(arg6))); } -#define ML_7_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5, value arg6, value arg7) \ -{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ - conv5(arg5), conv6(arg6), conv7(arg7))); } -#define ML_8_(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \ - conv) \ -CAMLprim value ml_##cname (value arg1, value arg2, value arg3, value arg4, \ - value arg5, value arg6, value arg7, value arg8) \ -{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \ - conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8))); } - -/* Use with care: needs the argument index */ -#define Ignore(x) -#define Split(x,f,g) f(x), g(x) Ignore -#define Split3(x,f,g,h) f(x), g(x), h(x) Ignore -#define Pair(x,f,g) f(Field(x,0)), g(Field(x,1)) Ignore -#define Triple(x,f,g,h) f(Field(x,0)), g(Field(x,1)), h(Field(x,2)) Ignore - -/* For more than 5 arguments */ -#define ML_bc6(cname) \ -CAMLprim value cname##_bc (value *argv, int argn) \ -{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5]); } - -#define ML_bc7(cname) \ -CAMLprim value cname##_bc (value *argv, int argn) \ -{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6]); } - -#define ML_bc8(cname) \ -CAMLprim value cname##_bc (value *argv, int argn) \ -{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \ - argv[7]); } - - -/* subtleties of openGL 1.1 vs 1.2 */ -#if !defined(GL_DOUBLE) && defined(GL_DOUBLE_EXT) -#define GL_DOUBLE GL_DOUBLE_EXT -#endif -#if !defined(GL_TEXTURE_PRIORITY) && defined(GL_TEXTURE_PRIORITY_EXT) -#define GL_TEXTURE_PRIORITY GL_TEXTURE_PRIORITY_EXT -#endif -#if !defined(GL_PROXY_TEXTURE_1D) && defined(GL_PROXY_TEXTURE_1D_EXT) -#define GL_PROXY_TEXTURE_1D GL_PROXY_TEXTURE_1D_EXT -#endif -#if !defined(GL_PROXY_TEXTURE_2D) && defined(GL_PROXY_TEXTURE_2D_EXT) -#define GL_PROXY_TEXTURE_2D GL_PROXY_TEXTURE_2D_EXT -#endif - -#endif diff --git a/lablGL/ml_glarray.c b/lablGL/ml_glarray.c deleted file mode 100644 index 275a262..0000000 --- a/lablGL/ml_glarray.c +++ /dev/null @@ -1,113 +0,0 @@ - -#ifdef _WIN32 -#include -#endif -#include -#include -#include -#include -#include -#include -#ifdef __APPLE__ -#include -#else -#include -#endif -#include "ml_gl.h" -#include "gl_tags.h" -#include "raw_tags.h" -#include "ml_raw.h" - -int ml_glSizeOfValue(value v) { - switch(v) { - case MLTAG_one: return(1); - case MLTAG_two: return(2); - case MLTAG_three: return(3); - case MLTAG_four: return(4); - default: ml_raise_gl("ml_glSizeOfValue: invalid size"); - } -} - - -CAMLprim value ml_glEdgeFlagPointer(value raw) -{ - glEdgeFlagPointer(0, (GLboolean*)Addr_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glTexCoordPointer(value size, value raw) -{ - glTexCoordPointer (ml_glSizeOfValue(size), - GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glColorPointer(value size, value raw) -{ - glColorPointer (ml_glSizeOfValue(size), - GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glIndexPointer(value raw) -{ - glIndexPointer (GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glNormalPointer(value raw) -{ - glNormalPointer (GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glVertexPointer(value size, value raw) -{ - glVertexPointer (ml_glSizeOfValue(size), - GLenum_val(Kind_raw(raw)), 0, Void_raw(raw)); - return Val_unit; -} - -CAMLprim value ml_glEnableClientState(value kl) -{ - GLenum a; - - switch(kl) { - case MLTAG_edge_flag: a = GL_EDGE_FLAG_ARRAY; break; - case MLTAG_texture_coord: a = GL_TEXTURE_COORD_ARRAY; break; - case MLTAG_color: a = GL_COLOR_ARRAY; break; - case MLTAG_index: a = GL_INDEX_ARRAY; break; - case MLTAG_normal: a = GL_NORMAL_ARRAY; break; - case MLTAG_vertex: a = GL_VERTEX_ARRAY; break; - default: ml_raise_gl("ml_glEnableClientState: invalid array"); - } - glEnableClientState(a); - return Val_unit; -} - -CAMLprim value ml_glDisableClientState(value kl) -{ - GLenum a; - - switch(kl) { - case MLTAG_edge_flag: a = GL_EDGE_FLAG_ARRAY; break; - case MLTAG_texture_coord: a = GL_TEXTURE_COORD_ARRAY; break; - case MLTAG_color: a = GL_COLOR_ARRAY; break; - case MLTAG_index: a = GL_INDEX_ARRAY; break; - case MLTAG_normal: a = GL_NORMAL_ARRAY; break; - case MLTAG_vertex: a = GL_VERTEX_ARRAY; break; - default: ml_raise_gl("ml_glDisableClientState: invalid array"); - } - glDisableClientState(a); - return Val_unit; -} - -ML_1 (glArrayElement, Int_val); -ML_3 (glDrawArrays, GLenum_val, Int_val, Int_val); - -CAMLprim value ml_glDrawElements(value mode, value count, value raw) -{ - glDrawElements (GLenum_val(mode), Int_val(count), - GLenum_val(Kind_raw(raw)), Void_raw(raw)); - return Val_unit; -} diff --git a/lablGL/ml_raw.c b/lablGL/ml_raw.c deleted file mode 100644 index d3116dc..0000000 --- a/lablGL/ml_raw.c +++ /dev/null @@ -1,506 +0,0 @@ -/* $Id: ml_raw.c,v 1.16 2007-04-13 02:48:43 garrigue Exp $ */ - -#include -#include -#include -#include -#include -#include -#include "raw_tags.h" -#include "ml_raw.h" - -#define SIZE_BYTE sizeof(char) -#define SIZE_SHORT sizeof(short) -#define SIZE_INT sizeof(int) -#define SIZE_LONG sizeof(long) -#define SIZE_FLOAT sizeof(float) -#define SIZE_DOUBLE sizeof(double) - -extern void caml_invalid_argument (char *) Noreturn; - -static int raw_sizeof (value kind) -{ - switch (kind) { - case MLTAG_bitmap: - case MLTAG_byte: - case MLTAG_ubyte: - return SIZE_BYTE; - case MLTAG_short: - case MLTAG_ushort: - return SIZE_SHORT; - case MLTAG_int: - case MLTAG_uint: - return SIZE_INT; - case MLTAG_long: - case MLTAG_ulong: - return SIZE_LONG; - case MLTAG_float: - return SIZE_FLOAT; - case MLTAG_double: - return SIZE_DOUBLE; - } - return 0; -} - -CAMLprim value ml_raw_sizeof (value kind) /* ML */ -{ - return Val_int(raw_sizeof(kind)); -} - -static void check_size (value raw, long pos, char *msg) -{ - if (pos < 0 || - (pos+1) * raw_sizeof(Kind_raw(raw)) > Int_val(Size_raw(raw))) - caml_invalid_argument (msg); -} - -CAMLprim value ml_raw_get (value raw, value pos) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.get"); - switch (Kind_raw(raw)) { - case MLTAG_bitmap: - case MLTAG_ubyte: - return Val_long ((unsigned char) Byte_raw(raw)[i]); - case MLTAG_byte: - return Val_long (Byte_raw(raw)[i]); - case MLTAG_short: - return Val_long (Short_raw(raw)[i]); - case MLTAG_ushort: - return Val_long ((unsigned short) Short_raw(raw)[i]); - case MLTAG_int: - return Val_long (Int_raw(raw)[i]); - case MLTAG_uint: - return Val_long ((unsigned int) Int_raw(raw)[i]); - case MLTAG_long: - return Val_long (Long_raw(raw)[i]); - case MLTAG_ulong: - return Val_long ((unsigned long) Long_raw(raw)[i]); - } - return Val_unit; -} - -CAMLprim value ml_raw_read (value raw, value pos, value len) /* ML */ -{ - int s = Int_val(pos); - int i, l = Int_val(len); - value ret; - - check_size (raw,s+l-1,"Raw.read"); - if (l<0 || s<0) caml_invalid_argument("Raw.read"); - ret = caml_alloc_shr (l, 0); - switch (Kind_raw(raw)) { - case MLTAG_bitmap: - case MLTAG_ubyte: - { - unsigned char *byte_raw = (unsigned char *)Byte_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*byte_raw++); - break; - } - case MLTAG_byte: - { - char *byte_raw = Byte_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*byte_raw++); - break; - } - case MLTAG_short: - { - short *short_raw = Short_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*short_raw++); - break; - } - case MLTAG_ushort: - { - unsigned short *short_raw = (unsigned short *)Short_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*short_raw++); - break; - } - case MLTAG_int: - { - int *int_raw = Int_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*int_raw++); - break; - } - case MLTAG_uint: - { - unsigned int *int_raw = (unsigned int *)Int_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*int_raw++); - break; - } - case MLTAG_long: - { - long *long_raw = Long_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*long_raw++); - break; - } - case MLTAG_ulong: - { - unsigned long *long_raw = (unsigned long *)Long_raw(raw)+s; - for (i = 0; i < l; i++) - Field(ret,i) = Val_long (*long_raw++); - break; - } - } - return ret; -} - -CAMLprim value ml_raw_read_string (value raw, value pos, value len) /* ML */ -{ - CAMLparam1(raw); - int s = Int_val(pos); - int l = Int_val(len); - value ret; - - if (l<0 || s<0 || s+l > Int_val(Size_raw(raw))) - caml_invalid_argument("Raw.read_string"); - ret = caml_alloc_string (l); - memcpy (Bp_val(ret), Bp_val(Addr_raw(raw))+s, l); - CAMLreturn(ret); -} - -CAMLprim value ml_raw_write_string (value raw, value pos, value data) /* ML */ -{ - int s = Int_val(pos); - int l = caml_string_length(data); - - if (s<0 || s+l > Int_val(Size_raw(raw))) - caml_invalid_argument("Raw.write_string"); - memcpy (Bp_val(Addr_raw(raw))+s, String_val(data), l); - return Val_unit; -} - -CAMLprim value ml_raw_set (value raw, value pos, value data) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.set"); - switch (Kind_raw(raw)) { - case MLTAG_bitmap: - case MLTAG_ubyte: - case MLTAG_byte: - Byte_raw(raw)[i] = Long_val(data); - break; - case MLTAG_short: - case MLTAG_ushort: - Short_raw(raw)[i] = Long_val(data); - break; - case MLTAG_int: - Int_raw(raw)[i] = Long_val(data); - break; - case MLTAG_uint: - Int_raw(raw)[i] = Long_val((unsigned long) data); - break; - case MLTAG_long: - Long_raw(raw)[i] = Long_val(data); - break; - case MLTAG_ulong: - Long_raw(raw)[i] = Long_val((unsigned long) data); - break; - } - return Val_unit; -} - -CAMLprim value ml_raw_write (value raw, value pos, value data) /* ML */ -{ - int s = Int_val(pos); - int i, l = Wosize_val(data); - - check_size (raw,s+l-1,"Raw.write"); - if (s<0) caml_invalid_argument("Raw.write"); - - switch (Kind_raw(raw)) { - case MLTAG_bitmap: - case MLTAG_ubyte: - case MLTAG_byte: - { - char *byte_raw = Byte_raw(raw)+s; - for (i = 0; i < l; i++) - *byte_raw++ = Long_val(Field(data,i)); - break; - } - case MLTAG_short: - case MLTAG_ushort: - { - short *short_raw = Short_raw(raw)+s; - for (i = 0; i < l; i++) - *short_raw++ = Long_val(Field(data,i)); - break; - } - case MLTAG_int: - { - int *int_raw = Int_raw(raw)+s; - for (i = 0; i < l; i++) - *int_raw++ = Long_val(Field(data,i)); - break; - } - case MLTAG_uint: - { - int *int_raw = Int_raw(raw)+s; - for (i = 0; i < l; i++) - *int_raw++ = Long_val((unsigned long) Field(data,i)); - break; - } - case MLTAG_long: - { - long *long_raw = Long_raw(raw)+s; - for (i = 0; i < l; i++) - *long_raw++ = Long_val(Field(data,i)); - break; - } - case MLTAG_ulong: - { - long *long_raw = Long_raw(raw)+s; - for (i = 0; i < l; i++) - *long_raw++ = Long_val((unsigned long) Field(data,i)); - break; - } - } - return Val_unit; -} - -CAMLprim value ml_raw_get_float (value raw, value pos) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.get_float"); - if (Kind_raw(raw) == MLTAG_float) - return caml_copy_double ((double) Float_raw(raw)[i]); - else - return caml_copy_double (Double_raw(raw)[i]); -} - -CAMLprim value ml_raw_read_float (value raw, value pos, value len) /* ML */ -{ - int s = Int_val(pos); - int i, l = Int_val(len); - value ret = Val_unit; - - check_size (raw,s+l-1,"Raw.read_float"); - if (l<0 || s<0) caml_invalid_argument("Raw.read_float"); - ret = caml_alloc_shr (l*sizeof(double)/sizeof(value), Double_array_tag); - if (Kind_raw(raw) == MLTAG_float) { - float *float_raw = Float_raw(raw)+s; - for (i = 0; i < l; i++) - Store_double_field(ret, i, (double) *float_raw++); - } else { - double *double_raw = Double_raw(raw)+s; - for (i = 0; i < l; i++) - Store_double_field(ret, i, *double_raw++); - } - return ret; -} - -CAMLprim value ml_raw_set_float (value raw, value pos, value data) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.set_float"); - if (Kind_raw(raw) == MLTAG_float) - Float_raw(raw)[i] = (float) Double_val(data); - else - Double_raw(raw)[i] = Double_val(data); - return Val_unit; -} - -CAMLprim value ml_raw_write_float (value raw, value pos, value data) /* ML */ -{ - int s = Int_val(pos); - int i, l = Wosize_val(data)*sizeof(value)/sizeof(double); - - check_size (raw,s+l-1,"Raw.write_float"); - if (s<0) caml_invalid_argument("Raw.write_float"); - if (Kind_raw(raw) == MLTAG_float) { - float *float_raw = Float_raw(raw)+s; - for (i = 0; i < l; i++) - *float_raw++ = (float) Double_field(data,i); - } else { - double *double_raw = Double_raw(raw)+s; - for (i = 0; i < l; i++) - *double_raw++ = Double_field(data,i); - } - return Val_unit; -} - -#ifdef ARCH_BIG_ENDIAN -#define HI_OFFSET 1 -#define LO_OFFSET 0 -#else -#define HI_OFFSET 0 -#define LO_OFFSET 1 -#endif - -/* Here we suppose that: - * sizeof(int) == 2*sizeof(short) - * sizeof(long) == 2*sizeof(int) (64-bit architectures) - * sizeof(long) == 2*sizeof(short) (otherwise) - */ - -#define Hint_raw(raw) ((unsigned short *) Short_raw(raw)) - -#ifdef ARCH_SIXTYFOUR -#define Hlong_raw(raw) ((unsigned int *) Int_raw(raw)) -#else -#define Hlong_raw(raw) ((unsigned short *) Short_raw(raw)) -#endif - -CAMLprim value ml_raw_get_hi (value raw, value pos) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.get_hi"); - switch (Kind_raw(raw)) { - case MLTAG_int: - case MLTAG_uint: - return Val_long (Hint_raw(raw)[2*i+HI_OFFSET]); - case MLTAG_long: - case MLTAG_ulong: - return Val_long (Hlong_raw(raw)[2*i+HI_OFFSET]); - } - return Val_unit; -} - -CAMLprim value ml_raw_get_lo (value raw, value pos) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.get_lo"); - switch (Kind_raw(raw)) { - case MLTAG_int: - case MLTAG_uint: - return Val_long ((unsigned long) Hint_raw(raw)[2*i+LO_OFFSET]); - case MLTAG_long: - case MLTAG_ulong: - return Val_long ((unsigned long) Hlong_raw(raw)[2*i+LO_OFFSET]); - } - return Val_unit; -} - -CAMLprim value ml_raw_set_hi (value raw, value pos, value data) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.set_hi"); - switch (Kind_raw(raw)) { - case MLTAG_int: - case MLTAG_uint: - Hint_raw(raw)[2*i+HI_OFFSET] = Long_val(data); - break; - case MLTAG_long: - case MLTAG_ulong: - Hlong_raw(raw)[2*i+HI_OFFSET] = Long_val(data); - break; - } - return Val_unit; -} - -CAMLprim value ml_raw_set_lo (value raw, value pos, value data) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.set_lo"); - switch (Kind_raw(raw)) { - case MLTAG_int: - case MLTAG_uint: - Hint_raw(raw)[2*i+LO_OFFSET] = Long_val(data); - break; - case MLTAG_long: - case MLTAG_ulong: - Hlong_raw(raw)[2*i+LO_OFFSET] = Long_val(data); - break; - } - return Val_unit; -} - -CAMLprim value ml_raw_get_long (value raw, value pos) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.get_long"); - switch (Kind_raw(raw)) { - case MLTAG_int: - case MLTAG_uint: - return caml_copy_nativeint (Int_raw(raw)[i]); - case MLTAG_long: - case MLTAG_ulong: - return caml_copy_nativeint (Long_raw(raw)[i]); - } - return Val_unit; -} - -CAMLprim value ml_raw_set_long (value raw, value pos, value data) /* ML */ -{ - long i = Long_val(pos); - - check_size (raw,i,"Raw.set_long"); - switch (Kind_raw(raw)) { - case MLTAG_int: - case MLTAG_uint: - Int_raw(raw)[i] = Nativeint_val(data); - break; - case MLTAG_long: - case MLTAG_ulong: - Long_raw(raw)[i] = Nativeint_val(data); - break; - } - return Val_unit; -} - -CAMLprim value ml_raw_alloc (value kind, value len) /* ML */ -{ - CAMLparam0(); - CAMLlocal1(data); - value raw; - int size = raw_sizeof(kind) * Int_val(len); - int offset = 0; - - if (kind == MLTAG_double && sizeof(double) > sizeof(value)) { - data = caml_alloc_shr ((size-1)/sizeof(value)+2, Abstract_tag); - offset = (data % sizeof(double) ? sizeof(value) : 0); - } else data = caml_alloc_shr ((size-1)/sizeof(value)+1, Abstract_tag); - raw = caml_alloc_small (SIZE_RAW,0); - Kind_raw(raw) = kind; - Size_raw(raw) = Val_int(size); - Base_raw(raw) = data; - Offset_raw(raw) = Val_int(offset); - Static_raw(raw) = Val_false; - CAMLreturn(raw); -} - -CAMLprim value ml_raw_alloc_static (value kind, value len) /* ML */ -{ - value raw; - void *data; - int size = raw_sizeof(kind) * Int_val(len); - int offset = 0; - - if (kind == MLTAG_double && sizeof(double) > sizeof(long)) { - data = caml_stat_alloc (size+sizeof(long)); - offset = ((long)data % sizeof(double) ? sizeof(value) : 0); - } else data = caml_stat_alloc (size); - raw = caml_alloc_small (SIZE_RAW, 0); - Kind_raw(raw) = kind; - Size_raw(raw) = Val_int(size); - Base_raw(raw) = (value) data; - Offset_raw(raw) = Val_int(offset); - Static_raw(raw) = Val_true; - return raw; -} - -CAMLprim value ml_raw_free_static (value raw) /* ML */ -{ - if (Static_raw(raw) != Val_int(1)) caml_invalid_argument ("Raw.free_static"); - caml_stat_free (Void_raw(raw)); - Base_raw(raw) = Val_unit; - Size_raw(raw) = Val_unit; - Offset_raw(raw) = Val_unit; - Static_raw(raw) = Val_false; - return Val_unit; -} diff --git a/lablGL/ml_raw.h b/lablGL/ml_raw.h deleted file mode 100644 index da94c933..0000000 --- a/lablGL/ml_raw.h +++ /dev/null @@ -1,23 +0,0 @@ -/* $Id: ml_raw.h,v 1.3 1999-04-14 14:05:52 garrigue Exp $ */ - -#ifndef _ml_raw_ -#define _ml_raw_ - -#define SIZE_RAW 5 -#define Kind_raw(raw) (Field(raw,0)) -#define Base_raw(raw) (Field(raw,1)) -#define Offset_raw(raw) (Field(raw,2)) -#define Size_raw(raw) (Field(raw,3)) -#define Static_raw(raw) (Field(raw,4)) - -#define Addr_raw(raw) (Base_raw(raw)+Long_val(Offset_raw(raw))) - -#define Void_raw(raw) ((void *) Addr_raw(raw)) -#define Byte_raw(raw) ((char *) Addr_raw(raw)) -#define Short_raw(raw) ((short *) Addr_raw(raw)) -#define Int_raw(raw) ((int *) Addr_raw(raw)) -#define Long_raw(raw) ((long *) Addr_raw(raw)) -#define Float_raw(raw) ((float *) Addr_raw(raw)) -#define Double_raw(raw) ((double *) Addr_raw(raw)) - -#endif diff --git a/lablGL/raw.ml b/lablGL/raw.ml deleted file mode 100644 index 19b7d53..0000000 --- a/lablGL/raw.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* $Id: raw.ml,v 1.9 2007-04-13 02:48:43 garrigue Exp $ *) - -type addr -type kind = - [`bitmap|`byte|`double|`float|`int|`long|`short - |`ubyte|`uint|`ulong|`ushort] -type fkind = [`double|`float] -type ikind = [`bitmap|`byte|`int|`long|`short|`ubyte|`uint|`ulong|`ushort] -type lkind = [`int|`long|`uint|`ulong] -type 'a t = - { kind: 'a; base: addr; offset: int; size: int; static: bool} - -let kind raw = raw.kind -let byte_size raw = raw.size -let static raw = raw.static -let cast raw ~kind = - { kind = kind; size = raw.size; base = raw.base; - offset = raw.offset; static = raw.static } - -external sizeof : [< kind] -> int = "ml_raw_sizeof" -let length raw = raw.size / sizeof raw.kind -let sub raw ~pos ~len = - let size = sizeof raw.kind in - if pos < 0 || (pos+len) * size > raw.size then invalid_arg "Raw.sub"; - { raw with offset = raw.offset + pos * size; size = len * size } - -external get : [< ikind] t -> pos:int -> int = "ml_raw_get" -external set : [< ikind] t -> pos:int -> int -> unit = "ml_raw_set" -external get_float : [< fkind] t -> pos:int -> float = "ml_raw_get_float" -external set_float : [< fkind] t -> pos:int -> float -> unit - = "ml_raw_set_float" -external get_hi : [< lkind] t -> pos:int -> int = "ml_raw_get_hi" -external set_hi : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_hi" -external get_lo : [< lkind] t -> pos:int -> int = "ml_raw_get_lo" -external set_lo : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_lo" -external get_long : [< lkind] t -> pos:int -> nativeint = "ml_raw_get_long" -external set_long : [< lkind] t -> pos:int -> nativeint -> unit - = "ml_raw_set_long" - -external gets : [< ikind] t -> pos:int -> len:int -> int array - = "ml_raw_read" -external gets_string : 'a t -> pos:int -> len:int -> string - = "ml_raw_read_string" -external gets_float : [< fkind] t -> pos:int -> len:int -> float array - = "ml_raw_read_float" -external sets : [< ikind] t -> pos:int -> int array -> unit = "ml_raw_write" -external sets_string : 'a t -> pos:int -> string -> unit - = "ml_raw_write_string" -external sets_float : [< fkind] t -> pos:int -> float array -> unit - = "ml_raw_write_float" - -(* -external fill : [< ikind] t -> pos:int -> len:int -> unit = "ml_raw_fill" -external fill_float : [< fkind] t -> pos:int -> len:int -> unit - = "ml_raw_fill_float" -*) - -external create : ([< kind] as 'a) -> len:int -> 'a t = "ml_raw_alloc" -external create_static : ([< kind] as 'a) -> len:int -> 'a t - = "ml_raw_alloc_static" -external free_static : 'a t -> unit = "ml_raw_free_static" - -let of_array arr ~kind = - let raw = create kind ~len:(Array.length arr) in - sets raw ~pos:0 arr; - raw -let of_float_array arr ~kind = - let raw = create kind ~len:(Array.length arr) in - sets_float raw ~pos:0 arr; - raw -let of_string s ~kind = - let raw = create kind ~len:(String.length s) in - sets_string raw ~pos:0 s; - raw -let of_matrix mat ~kind = - let h = Array.length mat in - if h = 0 then invalid_arg "Raw.of_matrix"; - let w = Array.length mat.(0) in - let raw = create kind ~len:(h*w) in - for i = 0 to h - 1 do - if Array.length mat.(i) <> w then invalid_arg "Raw.of_matrix"; - sets_float raw ~pos:(i*w) mat.(i) - done; - raw diff --git a/lablGL/raw.mli b/lablGL/raw.mli deleted file mode 100644 index 94c7b2c..0000000 --- a/lablGL/raw.mli +++ /dev/null @@ -1,83 +0,0 @@ -(* $Id: raw.mli,v 1.10 2007-04-13 02:48:43 garrigue Exp $ *) - -(* This module provides a direct way to access C arrays of basic types. - This is particularly useful when one wants to avoid costly - conversions between ML and C representations. *) - -type (+'a) t - -type kind = - [`bitmap|`byte|`double|`float|`int|`long|`short - |`ubyte|`uint|`ulong|`ushort] - (* Supported element types. [bitmap] is equivalent to [ubyte] but - allows user modules to distinguish between them *) -type fkind = [`double|`float] -type ikind = [`bitmap|`byte|`int|`long|`short|`ubyte|`uint|`ulong|`ushort] -type lkind = [`int|`long|`uint|`ulong] - -val create : ([< kind] as 'a) -> len:int -> 'a t - (* [create t :len] returns a new raw array of C type t - and length len. This array is managed by the GC *) -val create_static : ([< kind] as 'a) -> len:int -> 'a t - (* [create_static t :len] returns a new raw array of C type t - and length len. This array is created through malloc. - You must free it explicitely *) -val free_static : 'a t -> unit - (* Free a raw array created through create_static *) - -val kind : 'a t -> 'a - (* Returns the type of a free array. Beware of the influence on the - type system: you probably want to write [(kind raw :> kind)] *) -val byte_size : 'a t -> int - (* The size of the array in bytes. That is (sizeof t * len) - where t and len are the parameters to create *) -val static : 'a t -> bool - (* Wether this array was statically allocated or not *) -val cast : 'a t -> kind:([< kind] as 'b) -> 'b t - (* Change the type of a raw array *) - -external sizeof : [< kind] -> int = "ml_raw_sizeof" - (* [sizeof t] returns the physical size of t in bytes *) -val length : [< kind] t -> int - (* [length raw] returns the length of raw array according to - its contents type *) -val sub : ([< kind] t as 'a) -> pos:int -> len:int -> 'a - (* returns the slice of length len starting at position pos *) - -(* The following functions access raw arrays in the intuitive way. - They raise [Invalid_argument] when access is attempted out of - bounds *) - -external get : [< ikind] t -> pos:int -> int = "ml_raw_get" -external set : [< ikind] t -> pos:int -> int -> unit = "ml_raw_set" -external get_float : [< fkind] t -> pos:int -> float = "ml_raw_get_float" -external set_float : [< fkind] t -> pos:int -> float -> unit - = "ml_raw_set_float" -external get_hi : [< lkind] t -> pos:int -> int = "ml_raw_get_hi" -external set_hi : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_hi" -external get_lo : [< lkind] t -> pos:int -> int = "ml_raw_get_lo" -external set_lo : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_lo" -external get_long : [< lkind] t -> pos:int -> nativeint = "ml_raw_get_long" -external set_long : [< lkind] t -> pos:int -> nativeint -> unit - = "ml_raw_set_long" - -(* Simultaneous access versions are much more efficient than individual - access, the overhead being paid only once *) - -val gets : [< ikind] t -> pos:int -> len:int -> int array -val sets : [< ikind] t -> pos:int -> int array -> unit -val gets_float : [< fkind] t -> pos:int -> len:int -> float array -val sets_float : [< fkind] t -> pos:int -> float array -> unit - -(* Fastest version: simply copy the contents of the array to and from - a string *) - -val gets_string : 'a t -> pos:int -> len:int -> string -val sets_string : 'a t -> pos:int -> string -> unit - -(* Abbreviations to create raw arrays from ML arrays and strings *) - -val of_array : int array -> kind:([< ikind] as 'a) -> 'a t -val of_float_array : float array -> kind:([< fkind] as 'a) -> 'a t -val of_string : string -> kind:([< kind] as 'a) -> 'a t -val of_matrix : float array array -> kind:([< fkind] as 'a) -> 'a t diff --git a/lablGL/raw_tags.h b/lablGL/raw_tags.h deleted file mode 100644 index 81f1091..0000000 --- a/lablGL/raw_tags.h +++ /dev/null @@ -1,11 +0,0 @@ -#define MLTAG_bitmap Val_int(-250867729) -#define MLTAG_byte Val_int(-1054662904) -#define MLTAG_ubyte Val_int(520420861) -#define MLTAG_short Val_int(-64519044) -#define MLTAG_ushort Val_int(-1008157721) -#define MLTAG_int Val_int(5246191) -#define MLTAG_uint Val_int(-844758118) -#define MLTAG_long Val_int(-944265860) -#define MLTAG_ulong Val_int(630817905) -#define MLTAG_float Val_int(43435420) -#define MLTAG_double Val_int(852175633) diff --git a/link.c b/link.c deleted file mode 100644 index a4ef9df..0000000 --- a/link.c +++ /dev/null @@ -1,3681 +0,0 @@ -/* lots of code c&p-ed directly from mupdf */ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef LLPARANOIDP -#pragma GCC diagnostic error "-Weverything" -#pragma GCC diagnostic ignored "-Wpadded" -#pragma GCC diagnostic ignored "-Wsign-conversion" -#pragma GCC diagnostic ignored "-Wdocumentation-unknown-command" -#pragma GCC diagnostic ignored "-Wdocumentation" -#pragma GCC diagnostic ignored "-Wdouble-promotion" -#pragma GCC diagnostic ignored "-Wimplicit-int-float-conversion" -#else -#pragma GCC diagnostic error "-Wcast-qual" -#endif - -#include GL_H - -#define CAML_NAME_SPACE -#include -#include -#include -#include - -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wfloat-equal" -#include -#include -#pragma GCC diagnostic pop - -#pragma GCC diagnostic push -#ifdef __clang__ -#pragma GCC diagnostic ignored "-Wreserved-id-macro" -#endif -#include -#include FT_FREETYPE_H -#pragma GCC diagnostic pop - -#include "cutils.h" - -#define ARSERT(c) !(c) ? errx (1, "%s:%d " #c, __FILE__, __LINE__) : (void) 0 -#define ML(d) extern value ml_##d; value ml_##d -#define ML0(d) extern void ml_##d; void ml_##d -#define STTI(st) ((unsigned int) (st)) - -enum { Copen=23, Ccs, Cfreepage, Cfreetile, Csearch, Cgeometry, Creqlayout, - Cpage, Ctile, Ctrimset, Csettrim, Csliceh, Cinterrupt }; -enum { FitWidth, FitProportional, FitPage }; -enum { LDfirst, LDlast }; -enum { LDfirstvisible, LDleft, LDright, LDdown, LDup }; -enum { Uuri, Utext, Utextannot, Ufileannot, Unone }; -enum { MarkPage, MarkBlock, MarkLine, MarkWord }; - -struct slice { - int h; - int texindex; -}; - -struct tile { - int w, h; - int slicecount; - int sliceheight; - fz_pixmap *pixmap; - struct slice slices[1]; -}; - -struct pagedim { - int pageno; - int rotate; - int left; - int tctmready; - fz_irect bounds; - fz_rect pagebox; - fz_rect mediabox; - fz_matrix ctm, zoomctm, tctm; -}; - -struct slink { - enum { SLINK, SANNOT } tag; - fz_irect bbox; - union { - fz_link *link; - pdf_annot *annot; - } u; -}; - -struct annot { - fz_irect bbox; - pdf_annot *annot; -}; - -struct page { - int tgen; - int sgen; - int agen; - int pageno; - int pdimno; - fz_stext_page *text; - fz_page *fzpage; - fz_display_list *dlist; - fz_link *links; - int slinkcount; - struct slink *slinks; - int annotcount; - struct annot *annots; - fz_stext_char *fmark, *lmark; -}; - -static struct { - pthread_mutex_t mutex; - int sliceheight; - struct pagedim *pagedims; - int pagecount; - int pagedimcount; - fz_document *doc; - fz_context *ctx; - int w, h; - char *dcf; - int pfds[2]; - - struct { - int index, count; - GLuint *ids; - GLenum iform, form, ty; - struct { - int w, h; - struct slice *slice; - } *owners; - } tex; - - fz_colorspace *colorspace; - float papercolor[4]; - - FT_Face face; - fz_pixmap *pig; - pthread_t thread; - fz_irect trimfuzz; - GLuint stid, boid; - int trimmargins, needoutline, gen, rotate, aalevel, - fitmodel, trimanew, csock, dirty, utf8cs; - - GLfloat texcoords[8], vertices[16]; -} state = { .mutex = PTHREAD_MUTEX_INITIALIZER }; - -static void lock (const char *cap) -{ - int ret = pthread_mutex_lock (&state.mutex); - if (ret) { - errx (1, "%s: pthread_mutex_lock: %d(%s)", cap, ret, strerror (ret)); - } -} - -static void unlock (const char *cap) -{ - int ret = pthread_mutex_unlock (&state.mutex); - if (ret) { - errx (1, "%s: pthread_mutex_unlock: %d(%s)", cap, ret, strerror (ret)); - } -} - -static int trylock (const char *cap) -{ - int ret = pthread_mutex_trylock (&state.mutex); - if (ret && ret != EBUSY) { - errx (1, "%s: pthread_mutex_trylock: %d(%s)", cap, - ret, strerror (ret)); - } - return ret == EBUSY; -} - -static int hasdata (int fd) -{ - int ret, avail; - ret = ioctl (fd, FIONREAD, &avail); - if (ret) { - err (1, errno, "hasdata: FIONREAD error ret=%d", ret); - } - return avail > 0; -} - -ML (hasdata (value fd_v)) -{ - CAMLparam1 (fd_v); - CAMLreturn (Val_bool (hasdata (Int_val (fd_v)))); -} - -static void readdata (int fd, void *p, int size) -{ - ssize_t n; - -again: - n = read (fd, p, size); - if (n < 0) { - if (errno == EINTR) { - goto again; - } - err (1, errno, "writev (fd %d, req %d, ret %zd)", fd, size, n); - } - if (n - size) { - errx (1, "read (fd %d, req %d, ret %zd)", fd, size, n); - } -} - -static void writedata (int fd, char *p, int size) -{ - ssize_t n; - uint32_t size4 = size; - struct iovec iov[2] = { - { .iov_base = &size4, .iov_len = 4 }, - { .iov_base = p, .iov_len = size } - }; - -again: - n = writev (fd, iov, 2); - if (n < 0) { - if (errno == EINTR) { - goto again; - } - err (1, errno, "writev (fd %d, req %d, ret %zd)", fd, size + 4, n); - } - if (n - size - 4) { - errx (1, "writev (fd %d, req %d, ret %zd)", fd, size + 4, n); - } -} - -static int readlen (int fd) -{ - uint32_t u; - readdata (fd, &u, 4); - return u; -} - -ML0 (wcmd (value fd_v, value bytes_v, value len_v)) -{ - CAMLparam3 (fd_v, bytes_v, len_v); - writedata (Int_val (fd_v), &Byte (bytes_v, 0), Int_val (len_v)); - CAMLreturn0; -} - -ML (rcmd (value fd_v)) -{ - CAMLparam1 (fd_v); - CAMLlocal1 (strdata_v); - int fd = Int_val (fd_v); - int len = readlen (fd); - strdata_v = caml_alloc_string (len); - readdata (fd, Bytes_val (strdata_v), len); - CAMLreturn (strdata_v); -} - -static void GCC_FMT_ATTR (1, 2) printd (const char *fmt, ...) -{ - char fbuf[64]; - int size = sizeof (fbuf), len; - va_list ap; - char *buf = fbuf; - - for (;;) { - va_start (ap, fmt); - len = vsnprintf (buf, size, fmt, ap); - va_end (ap); - - if (len > -1) { - if (len < size - 4) { - writedata (state.csock, buf, len); - break; - } - else { - size = len + 5; - } - } - else { - err (1, errno, "vsnprintf for `%s' failed", fmt); - } - buf = realloc (buf == fbuf ? NULL : buf, size); - if (!buf) { - err (1, errno, "realloc for temp buf (%d bytes) failed", size); - } - } - if (buf != fbuf) { - free (buf); - } -} - -static void closedoc (void) -{ - if (state.doc) { - fz_drop_document (state.ctx, state.doc); - state.doc = NULL; - } -} - -static int openxref (char *filename, char *mimetype, char *password, - int w, int h, int em) -{ - for (int i = 0; i < state.tex.count; ++i) { - state.tex.owners[i].w = -1; - state.tex.owners[i].slice = NULL; - } - - closedoc (); - - state.dirty = 0; - if (state.pagedims) { - free (state.pagedims); - state.pagedims = NULL; - } - state.pagedimcount = 0; - - fz_set_aa_level (state.ctx, state.aalevel); - if (mimetype) { - fz_stream *st = fz_open_file (state.ctx, filename); - state.doc = fz_open_document_with_stream (state.ctx, mimetype, st); - } - else { - state.doc = fz_open_document (state.ctx, filename); - } - if (fz_needs_password (state.ctx, state.doc)) { - if (password && !*password) { - printd ("pass"); - return 0; - } - else { - int ok = fz_authenticate_password (state.ctx, state.doc, password); - if (!ok) { - printd ("pass fail"); - return 0; - } - } - } - if (w >= 0 || h >= 0 || em >=0) { - fz_layout_document (state.ctx, state.doc, w, h, em); - } - state.pagecount = fz_count_pages (state.ctx, state.doc); - if (state.pagecount < 0) { - state.pagecount = 0; - return 0; - } - return 1; -} - -static void docinfo (void) -{ - struct { char *tag; char *name; } tab[] = { - { FZ_META_INFO_TITLE, "Title" }, - { FZ_META_INFO_AUTHOR, "Author" }, - { FZ_META_FORMAT, "Format" }, - { FZ_META_ENCRYPTION, "Encryption" }, - { FZ_META_INFO_CREATOR, "Creator" }, - { FZ_META_INFO_PRODUCER, "Producer" }, - { FZ_META_INFO_CREATIONDATE, "Creation date" }, - { FZ_META_INFO_MODIFICATIONDATE, "Modification date"}, - }; - int len = 0, need; - char *buf = NULL; - - for (size_t i = 0; i < sizeof (tab) / sizeof (*tab); ++i) { - again: - need = fz_lookup_metadata (state.ctx, state.doc, tab[i].tag, buf, len); - if (need > 0) { - if (need <= len) { - printd ("info %s\t%s", tab[i].name, buf); - } - else { - buf = realloc (buf, need); - if (!buf) { - err (1, errno, "docinfo realloc %d", need); - } - len = need; - goto again; - } - } - } - free (buf); - - printd ("infoend"); -} - -static void unlinktile (struct tile *tile) -{ - for (int i = 0; i < tile->slicecount; ++i) { - struct slice *s = &tile->slices[i]; - - if (s->texindex != -1) { - if (state.tex.owners[s->texindex].slice == s) { - state.tex.owners[s->texindex].slice = NULL; - } - } - } -} - -static void freepage (struct page *page) -{ - if (page) { - fz_drop_stext_page (state.ctx, page->text); - free (page->slinks); - fz_drop_display_list (state.ctx, page->dlist); - fz_drop_page (state.ctx, page->fzpage); - free (page); - } -} - -static void freetile (struct tile *tile) -{ - unlinktile (tile); - fz_drop_pixmap (state.ctx, state.pig); - state.pig = tile->pixmap; - free (tile); -} - -static void trimctm (pdf_page *page, int pindex) -{ - struct pagedim *pdim = &state.pagedims[pindex]; - - if (!page) { - return; - } - if (!pdim->tctmready) { - fz_rect realbox, mediabox; - fz_matrix page_ctm, ctm; - - ctm = fz_concat (fz_rotate (-pdim->rotate), fz_scale (1, -1)); - realbox = fz_transform_rect (pdim->mediabox, ctm); - pdf_page_transform (state.ctx, page, &mediabox, &page_ctm); - pdim->tctm = fz_concat ( - fz_invert_matrix (page_ctm), - fz_concat (ctm, fz_translate (-realbox.x0, -realbox.y0))); - pdim->tctmready = 1; - } -} - -static fz_matrix pagectm1 (fz_page *fzpage, struct pagedim *pdim) -{ - fz_matrix ctm; - ptrdiff_t pdimno = pdim - state.pagedims; - - ARSERT (pdim - state.pagedims < INT_MAX); - if (pdf_specifics (state.ctx, state.doc)) { - trimctm (pdf_page_from_fz_page (state.ctx, fzpage), (int) pdimno); - ctm = fz_concat (pdim->tctm, pdim->ctm); - } - else { - ctm = fz_concat (fz_translate (-pdim->mediabox.x0, -pdim->mediabox.y0), - pdim->ctm); - } - return ctm; -} - -static fz_matrix pagectm (struct page *page) -{ - return pagectm1 (page->fzpage, &state.pagedims[page->pdimno]); -} - -static void *loadpage (int pageno, int pindex) -{ - fz_device *dev; - struct page *page; - - page = calloc (sizeof (struct page), 1); - if (!page) { - err (1, errno, "calloc page %d", pageno); - } - - page->dlist = fz_new_display_list (state.ctx, fz_infinite_rect); - dev = fz_new_list_device (state.ctx, page->dlist); - fz_try (state.ctx) { - page->fzpage = fz_load_page (state.ctx, state.doc, pageno); - fz_run_page (state.ctx, page->fzpage, dev, fz_identity, NULL); - } - fz_catch (state.ctx) { - page->fzpage = NULL; - } - fz_close_device (state.ctx, dev); - fz_drop_device (state.ctx, dev); - - page->pdimno = pindex; - page->pageno = pageno; - page->sgen = state.gen; - page->agen = state.gen; - page->tgen = state.gen; - return page; -} - -static struct tile *alloctile (int h) -{ - int slicecount; - size_t tilesize; - struct tile *tile; - - slicecount = (h + state.sliceheight - 1) / state.sliceheight; - tilesize = sizeof (*tile) + ((slicecount - 1) * sizeof (struct slice)); - tile = calloc (tilesize, 1); - if (!tile) { - err (1, errno, "cannot allocate tile (%zu bytes)", tilesize); - } - for (int i = 0; i < slicecount; ++i) { - int sh = fz_mini (h, state.sliceheight); - tile->slices[i].h = sh; - tile->slices[i].texindex = -1; - h -= sh; - } - tile->slicecount = slicecount; - tile->sliceheight = state.sliceheight; - return tile; -} - -static struct tile *rendertile (struct page *page, int x, int y, int w, int h) -{ - fz_irect bbox; - fz_matrix ctm; - fz_device *dev; - struct tile *tile; - struct pagedim *pdim; - - tile = alloctile (h); - pdim = &state.pagedims[page->pdimno]; - - bbox = pdim->bounds; - bbox.x0 += x; - bbox.y0 += y; - bbox.x1 = bbox.x0 + w; - bbox.y1 = bbox.y0 + h; - - if (state.pig) { - if (state.pig->w == w - && state.pig->h == h - && state.pig->colorspace == state.colorspace) { - tile->pixmap = state.pig; - tile->pixmap->x = bbox.x0; - tile->pixmap->y = bbox.y0; - } - else { - fz_drop_pixmap (state.ctx, state.pig); - } - state.pig = NULL; - } - if (!tile->pixmap) { - tile->pixmap = fz_new_pixmap_with_bbox (state.ctx, - state.colorspace, - bbox, NULL, 1); - } - - tile->w = w; - tile->h = h; - fz_fill_pixmap_with_color (state.ctx, tile->pixmap, - fz_device_rgb (state.ctx), - state.papercolor, - fz_default_color_params); - - dev = fz_new_draw_device (state.ctx, fz_identity, tile->pixmap); - ctm = pagectm (page); - fz_run_display_list (state.ctx, page->dlist, dev, ctm, - fz_rect_from_irect (bbox), NULL); - fz_close_device (state.ctx, dev); - fz_drop_device (state.ctx, dev); - - return tile; -} - -static void initpdims1 (void) -{ - int shown = 0; - struct pagedim *p; - pdf_document *pdf; - fz_context *ctx = state.ctx; - int pageno, trim, show, cxcount; - fz_rect rootmediabox = fz_empty_rect; - - fz_var (p); - fz_var (pdf); - fz_var (shown); - fz_var (pageno); - fz_var (cxcount); - - cxcount = state.pagecount; - if ((pdf = pdf_specifics (ctx, state.doc))) { - pdf_obj *obj = pdf_dict_getp (ctx, pdf_trailer (ctx, pdf), - "Root/Pages/MediaBox"); - rootmediabox = pdf_to_rect (ctx, obj); - pdf_load_page_tree (ctx, pdf); - } - - for (pageno = 0; pageno < cxcount; ++pageno) { - int rotate = 0; - fz_rect mediabox = fz_empty_rect; - - fz_var (rotate); - if (pdf) { - pdf_obj *pageobj = NULL; - - fz_var (pageobj); - if (pdf->rev_page_map) { - for (int i = 0; i < pdf->rev_page_count; ++i) { - if (pdf->rev_page_map[i].page == pageno) { - pageobj = pdf_get_xref_entry ( - ctx, pdf, pdf->rev_page_map[i].object - )->obj; - break; - } - } - } - if (!pageobj) { - pageobj = pdf_lookup_page_obj (ctx, pdf, pageno); - } - - rotate = pdf_to_int (ctx, pdf_dict_gets (ctx, pageobj, "Rotate")); - - if (state.trimmargins) { - pdf_obj *obj; - pdf_page *page; - - fz_try (ctx) { - page = pdf_load_page (ctx, pdf, pageno); - obj = pdf_dict_gets (ctx, pageobj, "llpp.TrimBox"); - trim = state.trimanew || !obj; - if (trim) { - fz_rect rect; - fz_device *dev; - fz_matrix ctm, page_ctm; - - dev = fz_new_bbox_device (ctx, &rect); - pdf_page_transform (ctx, page, &mediabox, &page_ctm); - ctm = fz_invert_matrix (page_ctm); - pdf_run_page (ctx, page, dev, fz_identity, NULL); - fz_close_device (ctx, dev); - fz_drop_device (ctx, dev); - - rect.x0 += state.trimfuzz.x0; - rect.x1 += state.trimfuzz.x1; - rect.y0 += state.trimfuzz.y0; - rect.y1 += state.trimfuzz.y1; - rect = fz_transform_rect (rect, ctm); - rect = fz_intersect_rect (rect, mediabox); - - if (!fz_is_empty_rect (rect)) { - mediabox = rect; - } - - obj = pdf_new_array (ctx, pdf, 4); - pdf_array_push_real (ctx, obj, mediabox.x0); - pdf_array_push_real (ctx, obj, mediabox.y0); - pdf_array_push_real (ctx, obj, mediabox.x1); - pdf_array_push_real (ctx, obj, mediabox.y1); - pdf_dict_puts (ctx, pageobj, "llpp.TrimBox", obj); - } - else { - mediabox.x0 = pdf_array_get_real (ctx, obj, 0); - mediabox.y0 = pdf_array_get_real (ctx, obj, 1); - mediabox.x1 = pdf_array_get_real (ctx, obj, 2); - mediabox.y1 = pdf_array_get_real (ctx, obj, 3); - } - - fz_drop_page (ctx, &page->super); - show = (pageno + 1 == state.pagecount) - || (trim ? pageno % 5 == 0 : pageno % 20 == 0); - if (show) { - printd ("progress %f Trimming %d", - (double) (pageno + 1) / state.pagecount, - pageno + 1); - } - } - fz_catch (ctx) { - printd ("emsg failed to load page %d", pageno); - } - } - else { - int empty = 0; - fz_rect cropbox; - - mediabox = - pdf_to_rect (ctx, - pdf_dict_get_inheritable ( - ctx, - pageobj, - PDF_NAME (MediaBox) - ) - ); - if (fz_is_empty_rect (mediabox)) { - mediabox.x0 = 0; - mediabox.y0 = 0; - mediabox.x1 = 612; - mediabox.y1 = 792; - empty = 1; - } - - cropbox = - pdf_to_rect (ctx, pdf_dict_gets (ctx, pageobj, "CropBox")); - if (!fz_is_empty_rect (cropbox)) { - if (empty) { - mediabox = cropbox; - } - else { - mediabox = fz_intersect_rect (mediabox, cropbox); - } - } - else { - if (empty) { - if (fz_is_empty_rect (rootmediabox)) { - printd ("emsg cannot find size of page %d", - pageno); - } - else { - mediabox = rootmediabox; - } - } - } - } - } - else { - if (state.trimmargins) { - fz_page *page; - - fz_try (ctx) { - page = fz_load_page (ctx, state.doc, pageno); - mediabox = fz_bound_page (ctx, page); - if (state.trimmargins) { - fz_rect rect; - fz_device *dev; - - dev = fz_new_bbox_device (ctx, &rect); - fz_run_page (ctx, page, dev, fz_identity, NULL); - fz_close_device (ctx, dev); - fz_drop_device (ctx, dev); - - rect.x0 += state.trimfuzz.x0; - rect.x1 += state.trimfuzz.x1; - rect.y0 += state.trimfuzz.y0; - rect.y1 += state.trimfuzz.y1; - rect = fz_intersect_rect (rect, mediabox); - - if (!fz_is_empty_rect (rect)) { - mediabox = rect; - } - } - fz_drop_page (ctx, page); - } - fz_catch (ctx) { - } - } - else { - fz_page *page; - fz_try (ctx) { - page = fz_load_page (ctx, state.doc, pageno); - mediabox = fz_bound_page (ctx, page); - fz_drop_page (ctx, page); - - show = !state.trimmargins && pageno % 20 == 0; - if (show) { - shown = 1; - printd ("progress %f Gathering dimensions %d", - (double) pageno / state.pagecount, pageno); - } - } - fz_catch (ctx) { - printd ("emsg failed to load page %d", pageno); - } - } - } - if (state.pagedimcount == 0 - || ((void) (p = &state.pagedims[state.pagedimcount-1]) - , p->rotate != rotate) - || memcmp (&p->mediabox, &mediabox, sizeof (mediabox))) { - size_t size; - - size = (state.pagedimcount + 1) * sizeof (*state.pagedims); - state.pagedims = realloc (state.pagedims, size); - if (!state.pagedims) { - err (1, errno, "realloc pagedims to %zu (%d elems)", - size, state.pagedimcount + 1); - } - - p = &state.pagedims[state.pagedimcount++]; - p->rotate = rotate; - p->mediabox = mediabox; - p->pageno = pageno; - } - } - state.trimanew = 0; - if (shown) { - printd ("progress 1"); - } -} - -static void initpdims (void) -{ - FILE *f = state.dcf ? fopen (state.dcf, "rb") : NULL; - if (f) { - size_t nread; - - nread = fread (&state.pagedimcount, sizeof (state.pagedimcount), 1, f); - if (nread - 1) { - err (1, errno, "fread pagedim %zu", sizeof (state.pagedimcount)); - } - size_t size = (state.pagedimcount + 1) * sizeof (*state.pagedims); - state.pagedims = realloc (state.pagedims, size); - if (!state.pagedims) { - err (1, errno, "realloc pagedims to %zu (%d elems)", - size, state.pagedimcount + 1); - } - if (fread (state.pagedims, - sizeof (*state.pagedims), - state.pagedimcount+1, - f) - (state.pagedimcount+1)) { - err (1, errno, "fread pagedim data %zu %d", - sizeof (*state.pagedims), state.pagedimcount+1); - } - fclose (f); - } - - if (!state.pagedims) { - initpdims1 (); - if (state.dcf) { - f = fopen (state.dcf, "wb"); - if (!f) { - err (1, errno, "fopen %s for writing", state.dcf); - } - if (fwrite (&state.pagedimcount, - sizeof (state.pagedimcount), 1, f) - 1) { - err (1, errno, "fwrite pagedimcunt %zu", - sizeof (state.pagedimcount)); - } - if (fwrite (state.pagedims, sizeof (*state.pagedims), - state.pagedimcount + 1, f) - - (state.pagedimcount + 1)) { - err (1, errno, "fwrite pagedim data %zu %u", - sizeof (*state.pagedims), state.pagedimcount+1); - } - fclose (f); - } - } -} - -static void layout (void) -{ - int pindex; - fz_rect box; - fz_matrix ctm; - struct pagedim *p = NULL; - float zw, w, maxw = 0.0, zoom = 1.0; - - if (state.pagedimcount == 0) { - return; - } - - switch (state.fitmodel) { - case FitProportional: - for (pindex = 0; pindex < state.pagedimcount; ++pindex) { - float x0, x1; - - p = &state.pagedims[pindex]; - box = fz_transform_rect (p->mediabox, - fz_rotate (p->rotate + state.rotate)); - - x0 = fz_min (box.x0, box.x1); - x1 = fz_max (box.x0, box.x1); - - w = x1 - x0; - maxw = fz_max (w, maxw); - zoom = state.w / maxw; - } - break; - - case FitPage: - maxw = state.w; - break; - - case FitWidth: - break; - - default: - ARSERT (0 && state.fitmodel); - } - - for (pindex = 0; pindex < state.pagedimcount; ++pindex) { - p = &state.pagedims[pindex]; - ctm = fz_rotate (state.rotate); - box = fz_transform_rect (p->mediabox, - fz_rotate (p->rotate + state.rotate)); - w = box.x1 - box.x0; - switch (state.fitmodel) { - case FitProportional: - p->left = (int) (((maxw - w) * zoom) / 2.f); - break; - case FitPage: - { - float zh, h; - zw = maxw / w; - h = box.y1 - box.y0; - zh = state.h / h; - zoom = fz_min (zw, zh); - p->left = (int) ((maxw - (w * zoom)) / 2.f); - } - break; - case FitWidth: - p->left = 0; - zoom = state.w / w; - break; - } - - p->zoomctm = fz_scale (zoom, zoom); - ctm = fz_concat (p->zoomctm, ctm); - - p->pagebox = p->mediabox; - p->pagebox = fz_transform_rect (p->pagebox, fz_rotate (p->rotate)); - p->pagebox.x1 -= p->pagebox.x0; - p->pagebox.y1 -= p->pagebox.y0; - p->pagebox.x0 = 0; - p->pagebox.y0 = 0; - p->bounds = fz_round_rect (fz_transform_rect (p->pagebox, ctm)); - p->ctm = ctm; - - ctm = fz_concat (fz_translate (0, -p->mediabox.y1), - fz_scale (zoom, -zoom)); - p->tctmready = 0; - } - - do { - printd ("pdim %u %d %d %d", p->pageno, p->left, - abs (p->bounds.x0 - p->bounds.x1), - abs (p->bounds.y0 - p->bounds.y1)); - } while (p-- != state.pagedims); -} - -static struct pagedim *pdimofpageno (int pageno) -{ - struct pagedim *pdim = state.pagedims; - - for (int i = 0; i < state.pagedimcount; ++i) { - if (state.pagedims[i].pageno > pageno) { - break; - } - pdim = &state.pagedims[i]; - } - return pdim; -} - -static void recurse_outline (fz_outline *outline, int level) -{ - while (outline) { - int pageno; - fz_point p; - fz_location loc; - - loc = fz_resolve_link (state.ctx, state.doc, String_val (outline->uri), - &p.x, &p.y); - pageno = fz_page_number_from_location (state.ctx, state.doc, loc); - if (pageno >= 0) { - struct pagedim *pdim = - pdimofpageno ( - fz_page_number_from_location (state.ctx, state.doc, - outline->page) - ); - int h = fz_maxi (fz_absi (pdim->bounds.y1 - pdim->bounds.y0), 0); - p = fz_transform_point (p, pdim->ctm); - printd ("o %d %d %d %d %s", - level, pageno, (int) p.y, h, outline->title); - } - else { - printd ("on %d %s", level, outline->title); - } - if (outline->down) { - recurse_outline (outline->down, level + 1); - } - outline = outline->next; - } -} - -static void process_outline (void) -{ - if (state.needoutline && state.pagedimcount) { - fz_outline *outline = NULL; - - fz_var (outline); - fz_try (state.ctx) { - outline = fz_load_outline (state.ctx, state.doc); - state.needoutline = 0; - if (outline) { - recurse_outline (outline, 0); - } - } - fz_always (state.ctx) { - if (outline) { - fz_drop_outline (state.ctx, outline); - } - } - fz_catch (state.ctx) { - printd ("emsg %s", fz_caught_message (state.ctx)); - } - } -} - -static char *strofline (fz_stext_line *line) -{ - char *p; - char utf8[10]; - fz_stext_char *ch; - size_t size = 0, cap = 80; - - p = malloc (cap + 1); - if (!p) { - return NULL; - } - - for (ch = line->first_char; ch; ch = ch->next) { - int n = fz_runetochar (utf8, ch->c); - if (size + n > cap) { - cap *= 2; - p = realloc (p, cap + 1); - if (!p) { - return NULL; - } - } - - memcpy (p + size, utf8, n); - size += n; - } - p[size] = 0; - return p; -} - -enum a_searchresult { Found=61, NotFound, Interrupted, Error }; - -static enum a_searchresult matchline (regex_t *re, fz_stext_line *line, - int num_matches, int pageno) -{ - int ret; - char *p; - regmatch_t rm; - - p = strofline (line); - if (!p) { - return Error; - } - - ret = regexec (re, p, 1, &rm, 0); - free (p); - - if (ret) { - if (ret != REG_NOMATCH) { - int isize; - size_t size; - char errbuf[80], *trail; - - size = regerror (ret, re, errbuf, sizeof (errbuf)); - if (size > 23) { - isize = 23; - trail = "..."; - } - else { - isize = (int) size; - trail = ""; - } - printd ("emsg regexec error '%*s%s'", isize, errbuf, trail); - return Error; - } - return NotFound; - } - else { - int o = 0; - fz_quad s = line->first_char->quad, e; - fz_stext_char *ch; - - if (rm.rm_so == rm.rm_eo) { - return Found; - } - - for (ch = line->first_char; ch; ch = ch->next) { - o += fz_runelen (ch->c); - if (o > rm.rm_so) { - s = ch->quad; - break; - } - } - for (;ch; ch = ch->next) { - o += fz_runelen (ch->c); - if (o > rm.rm_eo) { - break; - } - } - e = ch->quad; - - printd ("match %d %d %f %f %f %f %f %f %f %f", - pageno, num_matches, - s.ul.x, s.ul.y, - e.ur.x, s.ul.y, - e.lr.x, e.lr.y, - s.ul.x, e.lr.y); - return Found; - } -} - -/* wishful thinking function */ -static void search (regex_t *re, int pageno, int y, int forward) -{ - fz_device *tdev; - double dur, start; - char *cap = "bug"; - struct pagedim *pdim; - fz_page *page = NULL; - fz_stext_block *block; - fz_stext_page *text = NULL; - int niters = 0, num_matches = 0; - enum a_searchresult the_searchresult = NotFound; - - start = now (); - while (pageno >= 0 && pageno < state.pagecount && num_matches == 0) { - if (niters++ == 5) { - niters = 0; - if (hasdata (state.csock)) { - fz_drop_stext_page (state.ctx, text); - fz_drop_page (state.ctx, page); - the_searchresult = Interrupted; - break; - } - else { - printd ("progress %f searching in page %d", - (double) (pageno + 1) / state.pagecount, pageno); - } - } - pdim = pdimofpageno (pageno); - text = fz_new_stext_page (state.ctx, pdim->mediabox); - tdev = fz_new_stext_device (state.ctx, text, 0); - - page = fz_load_page (state.ctx, state.doc, pageno); - fz_run_page (state.ctx, page, tdev, pagectm1 (page, pdim), NULL); - - fz_close_device (state.ctx, tdev); - fz_drop_device (state.ctx, tdev); - - if (forward) { - for (block = text->first_block; block; block = block->next) { - fz_stext_line *line; - - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - - for (line = block->u.t.first_line; line; line = line->next) { - if (line->bbox.y0 < y + 1) { - continue; - } - - the_searchresult = - matchline (re, line, num_matches, pageno); - num_matches += the_searchresult == Found; - } - } - } - else { - for (block = text->last_block; block; block = block->prev) { - fz_stext_line *line; - - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - - for (line = block->u.t.last_line; line; line = line->prev) { - if (line->bbox.y0 < y + 1) { - continue; - } - - the_searchresult = - matchline (re, line, num_matches, pageno); - num_matches += the_searchresult == Found; - } - } - } - - if (forward) { - pageno += 1; - y = 0; - } - else { - pageno -= 1; - y = INT_MAX; - } - fz_drop_stext_page (state.ctx, text); - text = NULL; - fz_drop_page (state.ctx, page); - page = NULL; - } - dur = now () - start; - switch (the_searchresult) { - case Found: case NotFound: cap = ""; break; - case Error: cap = "error "; break; - case Interrupted: cap = "interrupt "; break; - } - if (num_matches) { - printd ("progress 1 %sfound %d in %f sec", cap, num_matches, dur); - } - else { - printd ("progress 1 %sfound nothing in %f sec", cap, dur); - } - printd ("clearrects"); -} - -static void set_tex_params (int colorspace) -{ - switch (colorspace) { - case 0: - state.tex.iform = GL_RGBA8; - state.tex.form = GL_RGBA; - state.tex.ty = GL_UNSIGNED_BYTE; - state.colorspace = fz_device_rgb (state.ctx); - break; - case 1: - state.tex.iform = GL_LUMINANCE_ALPHA; - state.tex.form = GL_LUMINANCE_ALPHA; - state.tex.ty = GL_UNSIGNED_BYTE; - state.colorspace = fz_device_gray (state.ctx); - break; - default: - errx (1, "invalid colorspce %d", colorspace); - } -} - -static void realloctexts (int texcount) -{ - size_t size; - - if (texcount == state.tex.count) { - return; - } - - if (texcount < state.tex.count) { - glDeleteTextures (state.tex.count - texcount, state.tex.ids + texcount); - } - - size = texcount * (sizeof (*state.tex.ids) + sizeof (*state.tex.owners)); - state.tex.ids = realloc (state.tex.ids, size); - if (!state.tex.ids) { - err (1, errno, "realloc texs %zu", size); - } - - state.tex.owners = (void *) (state.tex.ids + texcount); - if (texcount > state.tex.count) { - glGenTextures (texcount - state.tex.count, - state.tex.ids + state.tex.count); - for (int i = state.tex.count; i < texcount; ++i) { - state.tex.owners[i].w = -1; - state.tex.owners[i].slice = NULL; - } - } - state.tex.count = texcount; - state.tex.index = 0; -} - -static char *mbtoutf8 (char *s) -{ - char *p, *r; - wchar_t *tmp; - size_t i, ret, len; - - if (state.utf8cs) { - return s; - } - - len = mbstowcs (NULL, s, strlen (s)); - if (len == 0 || len == (size_t) -1) { - if (len) { - printd ("emsg mbtoutf8: mbstowcs: %d(%s)", errno, strerror (errno)); - } - return s; - } - - tmp = calloc (len, sizeof (wchar_t)); - if (!tmp) { - printd ("emsg mbtoutf8: calloc(%zu, %zu): %d(%s)", - len, sizeof (wchar_t), errno, strerror (errno)); - return s; - } - - ret = mbstowcs (tmp, s, len); - if (ret == (size_t) -1) { - printd ("emsg mbtoutf8: mbswcs %zu characters failed: %d(%s)", - len, errno, strerror (errno)); - free (tmp); - return s; - } - - len = 0; - for (i = 0; i < ret; ++i) { - len += fz_runelen (tmp[i]); - } - - p = r = malloc (len + 1); - if (!r) { - printd ("emsg mbtoutf8: malloc(%zu)", len); - free (tmp); - return s; - } - - for (i = 0; i < ret; ++i) { - p += fz_runetochar (p, tmp[i]); - } - *p = 0; - free (tmp); - return r; -} - -ML (mbtoutf8 (value s_v)) -{ - CAMLparam1 (s_v); - CAMLlocal1 (ret_v); - char *s, *r; - - s = &Byte (s_v, 0); - r = mbtoutf8 (s); - if (r == s) { - ret_v = s_v; - } - else { - ret_v = caml_copy_string (r); - free (r); - } - CAMLreturn (ret_v); -} - -static void *mainloop (void UNUSED_ATTR *unused) -{ - char *p = NULL, c; - int len, ret, oldlen = 0; - - fz_var (p); - fz_var (oldlen); - for (;;) { - len = readlen (state.csock); - if (len == 0) { - errx (1, "readlen returned 0"); - } - - if (oldlen < len) { - p = realloc (p, len); - if (!p) { - err (1, errno, "realloc %d failed", len); - } - oldlen = len; - } - readdata (state.csock, p, len); - c = p[len-1]; - p[len-1] = 0; - - switch (c) { - case Copen: { - int off, usedoccss, ok = 0; - int w, h, em; - char *password, *mimetype, *filename, *utf8filename; - size_t filenamelen, mimetypelen; - - fz_var (ok); - ret = sscanf (p, "%d %d %d %d %n", &usedoccss, &w, &h, &em, &off); - if (ret != 4) { - errx (1, "malformed open `%.*s' ret=%d", len, p, ret); - } - - filename = p + off; - filenamelen = strlen (filename); - - mimetype = filename + filenamelen + 1; - mimetypelen = strlen (mimetype); - - password = mimetype + mimetypelen + 1; - - if (password[strlen (password) + 1]) { - fz_set_user_css (state.ctx, password + strlen (password) + 1); - } - - lock ("open"); - fz_set_use_document_css (state.ctx, usedoccss); - fz_try (state.ctx) { - ok = openxref (filename, mimetypelen ? mimetype : NULL, - password, w, h, em); - } - fz_catch (state.ctx) { - utf8filename = mbtoutf8 (filename); - printd ("emsg failed to load %s: %s", utf8filename, - fz_caught_message (state.ctx)); - if (utf8filename != filename) { - free (utf8filename); - } - } - if (ok) { - docinfo (); - initpdims (); - } - unlock ("open"); - state.needoutline = ok; - break; - } - case Ccs: { - int i, colorspace; - - ret = sscanf (p, "%d", &colorspace); - if (ret != 1) { - errx (1, "malformed cs `%.*s' ret=%d", len, p, ret); - } - lock ("cs"); - set_tex_params (colorspace); - for (i = 0; i < state.tex.count; ++i) { - state.tex.owners[i].w = -1; - state.tex.owners[i].slice = NULL; - } - unlock ("cs"); - break; - } - case Cfreepage: { - void *ptr; - - ret = sscanf (p, "%" SCNxPTR, (uintptr_t *) &ptr); - if (ret != 1) { - errx (1, "malformed freepage `%.*s' ret=%d", len, p, ret); - } - lock ("freepage"); - freepage (ptr); - unlock ("freepage"); - break; - } - case Cfreetile: { - void *ptr; - - ret = sscanf (p, "%" SCNxPTR, (uintptr_t *) &ptr); - if (ret != 1) { - errx (1, "malformed freetile `%.*s' ret=%d", len, p, ret); - } - lock ("freetile"); - freetile (ptr); - unlock ("freetile"); - break; - } - case Csearch: { - int icase, pageno, y, len2, forward; - regex_t re; - - ret = sscanf (p, "%d %d %d %d,%n", - &icase, &pageno, &y, &forward, &len2); - if (ret != 4) { - errx (1, "malformed search `%s' ret=%d", p, ret); - } - - char *pat = p + len2; - ret = regcomp (&re, pat, REG_EXTENDED | (icase ? REG_ICASE : 0)); - if (ret) { - char errbuf[80]; - size_t size; - - size = regerror (ret, &re, errbuf, sizeof (errbuf)); - printd ("emsg regcomp failed `%.*s'", (int) size, errbuf); - } - else { - lock ("search"); - search (&re, pageno, y, forward); - unlock ("search"); - regfree (&re); - } - break; - } - case Cgeometry: { - int w, h, fitmodel; - - printd ("clear"); - ret = sscanf (p, "%d %d %d", &w, &h, &fitmodel); - if (ret != 3) { - errx (1, "malformed geometry `%.*s' ret=%d", len, p, ret); - } - - lock ("geometry"); - state.h = h; - if (w != state.w) { - state.w = w; - for (int i = 0; i < state.tex.count; ++i) { - state.tex.owners[i].slice = NULL; - } - } - state.fitmodel = fitmodel; - layout (); - process_outline (); - - state.gen++; - unlock ("geometry"); - printd ("continue %d", state.pagecount); - break; - } - case Creqlayout: { - char *nameddest; - int rotate, off, h; - int fitmodel; - pdf_document *pdf; - - printd ("clear"); - ret = sscanf (p, "%d %d %d %n", &rotate, &fitmodel, &h, &off); - if (ret != 3) { - errx (1, "bad reqlayout line `%.*s' ret=%d", len, p, ret); - } - lock ("reqlayout"); - pdf = pdf_specifics (state.ctx, state.doc); - if (state.rotate != rotate || state.fitmodel != fitmodel) { - state.gen += 1; - } - state.rotate = rotate; - state.fitmodel = fitmodel; - state.h = h; - layout (); - process_outline (); - - nameddest = p + off; - if (pdf && nameddest && *nameddest) { - fz_point xy; - struct pagedim *pdim; - int pageno = pdf_lookup_anchor (state.ctx, pdf, nameddest, - &xy.x, &xy.y); - pdim = pdimofpageno (pageno); - xy = fz_transform_point (xy, pdim->ctm); - printd ("a %d %d %d", pageno, (int) xy.x, (int) xy.y); - } - - state.gen++; - unlock ("reqlayout"); - printd ("continue %d", state.pagecount); - break; - } - case Cpage: { - double a, b; - struct page *page; - int pageno, pindex; - - ret = sscanf (p, "%d %d", &pageno, &pindex); - if (ret != 2) { - errx (1, "bad page line `%.*s' ret=%d", len, p, ret); - } - - lock ("page"); - a = now (); - page = loadpage (pageno, pindex); - b = now (); - unlock ("page"); - - printd ("page %" PRIxPTR " %f", (uintptr_t) page, b - a); - break; - } - case Ctile: { - int x, y, w, h; - struct page *page; - struct tile *tile; - double a, b; - - ret = sscanf (p, "%" SCNxPTR " %d %d %d %d", - (uintptr_t *) &page, &x, &y, &w, &h); - if (ret != 5) { - errx (1, "bad tile line `%.*s' ret=%d", len, p, ret); - } - - lock ("tile"); - a = now (); - tile = rendertile (page, x, y, w, h); - b = now (); - unlock ("tile"); - - printd ("tile %d %d %" PRIxPTR " %u %f", - x, y, (uintptr_t) tile, - tile->w * tile->h * tile->pixmap->n, b - a); - break; - } - case Ctrimset: { - fz_irect fuzz; - int trimmargins; - - ret = sscanf (p, "%d %d %d %d %d", - &trimmargins, &fuzz.x0, &fuzz.y0, &fuzz.x1, &fuzz.y1); - if (ret != 5) { - errx (1, "malformed trimset `%.*s' ret=%d", len, p, ret); - } - - lock ("trimset"); - state.trimmargins = trimmargins; - if (memcmp (&fuzz, &state.trimfuzz, sizeof (fuzz))) { - state.trimanew = 1; - state.trimfuzz = fuzz; - } - unlock ("trimset"); - break; - } - case Csettrim: { - fz_irect fuzz; - int trimmargins; - - ret = sscanf (p, "%d %d %d %d %d", &trimmargins, - &fuzz.x0, &fuzz.y0, &fuzz.x1, &fuzz.y1); - if (ret != 5) { - errx (1, "malformed settrim `%.*s' ret=%d", len, p, ret); - } - printd ("clear"); - lock ("settrim"); - state.trimmargins = trimmargins; - state.needoutline = 1; - if (memcmp (&fuzz, &state.trimfuzz, sizeof (fuzz))) { - state.trimanew = 1; - state.trimfuzz = fuzz; - } - state.pagedimcount = 0; - free (state.pagedims); - state.pagedims = NULL; - initpdims (); - layout (); - process_outline (); - unlock ("settrim"); - printd ("continue %d", state.pagecount); - break; - } - case Csliceh: { - int h; - - ret = sscanf (p, "%d", &h); - if (ret != 1) { - errx (1, "malformed sliceh `%.*s' ret=%d", len, p, ret); - } - if (h != state.sliceheight) { - state.sliceheight = h; - for (int i = 0; i < state.tex.count; ++i) { - state.tex.owners[i].w = -1; - state.tex.owners[i].h = -1; - state.tex.owners[i].slice = NULL; - } - } - break; - } - case Cinterrupt: - printd ("vmsg interrupted"); - break; - default: - errx (1, "unknown llpp ffi command - %d [%.*s]", c, len, p); - } - } - return 0; -} - -ML (isexternallink (value uri_v)) -{ - CAMLparam1 (uri_v); - CAMLreturn (Val_bool (fz_is_external_link (state.ctx, String_val (uri_v)))); -} - -ML (uritolocation (value uri_v)) -{ - CAMLparam1 (uri_v); - CAMLlocal1 (ret_v); - fz_location loc; - int pageno; - fz_point xy; - struct pagedim *pdim; - - loc = fz_resolve_link (state.ctx, state.doc, String_val (uri_v), - &xy.x, &xy.y); - pageno = fz_page_number_from_location (state.ctx, state.doc, loc); - pdim = pdimofpageno (pageno); - xy = fz_transform_point (xy, pdim->ctm); - ret_v = caml_alloc_tuple (3); - Field (ret_v, 0) = Val_int (pageno); - Field (ret_v, 1) = caml_copy_double ((double) xy.x); - Field (ret_v, 2) = caml_copy_double ((double) xy.y); - CAMLreturn (ret_v); -} - -ML (realloctexts (value texcount_v)) -{ - CAMLparam1 (texcount_v); - int ok; - - if (trylock (__func__)) { - ok = 0; - goto done; - } - realloctexts (Int_val (texcount_v)); - ok = 1; - unlock (__func__); - - done: - CAMLreturn (Val_bool (ok)); -} - -static void recti (int x0, int y0, int x1, int y1) -{ - GLfloat *v = state.vertices; - - glVertexPointer (2, GL_FLOAT, 0, v); - v[0] = x0; v[1] = y0; - v[2] = x1; v[3] = y0; - v[4] = x0; v[5] = y1; - v[6] = x1; v[7] = y1; - glDrawArrays (GL_TRIANGLE_STRIP, 0, 4); -} - -static void showsel (struct page *page, int ox, int oy) -{ - fz_irect bbox; - fz_rect rect; - fz_stext_block *block; - int seen = 0; - unsigned char selcolor[] = {15,15,15,140}; - - if (!page->fmark || !page->lmark) { - return; - } - - glEnable (GL_BLEND); - glBlendFunc (GL_SRC_ALPHA, GL_SRC_ALPHA); - glColor4ubv (selcolor); - - ox += state.pagedims[page->pdimno].bounds.x0; - oy += state.pagedims[page->pdimno].bounds.y0; - - for (block = page->text->first_block; block; block = block->next) { - fz_stext_line *line; - - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - for (line = block->u.t.first_line; line; line = line->next) { - fz_stext_char *ch; - - rect = fz_empty_rect; - for (ch = line->first_char; ch; ch = ch->next) { - fz_rect r; - if (ch == page->fmark) { - seen = 1; - } - r = fz_rect_from_quad (ch->quad); - if (seen) { - rect = fz_union_rect (rect, r); - } - if (ch == page->lmark) { - bbox = fz_round_rect (rect); - recti (bbox.x0 + ox, bbox.y0 + oy, - bbox.x1 + ox, bbox.y1 + oy); - goto done; - } - } - if (!fz_is_empty_rect (rect)) { - bbox = fz_round_rect (rect); - recti (bbox.x0 + ox, bbox.y0 + oy, - bbox.x1 + ox, bbox.y1 + oy); - } - } - } -done: - glDisable (GL_BLEND); -} - -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wconversion" -#include "glfont.c" -#pragma GCC diagnostic pop - -static void stipplerect (fz_matrix m, fz_point p[4], - GLfloat *texcoords, GLfloat *vertices) -{ - fz_point p1 = fz_transform_point (p[0], m); - fz_point p2 = fz_transform_point (p[1], m); - fz_point p3 = fz_transform_point (p[2], m); - fz_point p4 = fz_transform_point (p[3], m); - - float w = p2.x - p1.x; - float h = p2.y - p1.y; - float t = hypotf (w, h) * .25f; - - w = p3.x - p2.x; - h = p3.y - p2.y; - float s = hypotf (w, h) * .25f; - - texcoords[0] = 0; vertices[0] = p1.x; vertices[1] = p1.y; - texcoords[1] = t; vertices[2] = p2.x; vertices[3] = p2.y; - - texcoords[2] = 0; vertices[4] = p2.x; vertices[5] = p2.y; - texcoords[3] = s; vertices[6] = p3.x; vertices[7] = p3.y; - - texcoords[4] = 0; vertices[8] = p3.x; vertices[9] = p3.y; - texcoords[5] = t; vertices[10] = p4.x; vertices[11] = p4.y; - - texcoords[6] = 0; vertices[12] = p4.x; vertices[13] = p4.y; - texcoords[7] = s; vertices[14] = p1.x; vertices[15] = p1.y; - - glDrawArrays (GL_LINES, 0, 8); -} - -static void ensurelinks (struct page *page) -{ - if (!page->links) { - page->links = fz_load_links (state.ctx, page->fzpage); - } -} - -static void highlightlinks (struct page *page, int xoff, int yoff) -{ - fz_point p[4]; - fz_matrix ctm; - fz_link *link; - GLfloat *texcoords = state.texcoords; - GLfloat *vertices = state.vertices; - - ensurelinks (page); - - glEnable (GL_TEXTURE_1D); - glEnable (GL_BLEND); - glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture (GL_TEXTURE_1D, state.stid); - - xoff -= state.pagedims[page->pdimno].bounds.x0; - yoff -= state.pagedims[page->pdimno].bounds.y0; - ctm = fz_concat (pagectm (page), fz_translate (xoff, yoff)); - - glTexCoordPointer (1, GL_FLOAT, 0, texcoords); - glVertexPointer (2, GL_FLOAT, 0, vertices); - - for (link = page->links; link; link = link->next) { - - p[0].x = link->rect.x0; - p[0].y = link->rect.y0; - - p[1].x = link->rect.x1; - p[1].y = link->rect.y0; - - p[2].x = link->rect.x1; - p[2].y = link->rect.y1; - - p[3].x = link->rect.x0; - p[3].y = link->rect.y1; - - /* TODO: different colours for different schemes */ - if (fz_is_external_link (state.ctx, link->uri)) { - glColor3ub (0, 0, 255); - } - else { - glColor3ub (255, 0, 0); - } - - stipplerect (ctm, p, texcoords, vertices); - } - - for (int i = 0; i < page->annotcount; ++i) { - struct annot *annot = &page->annots[i]; - - p[0].x = annot->bbox.x0; - p[0].y = annot->bbox.y0; - - p[1].x = annot->bbox.x1; - p[1].y = annot->bbox.y0; - - p[2].x = annot->bbox.x1; - p[2].y = annot->bbox.y1; - - p[3].x = annot->bbox.x0; - p[3].y = annot->bbox.y1; - - glColor3ub (0, 0, 128); - stipplerect (ctm, p, texcoords, vertices); - } - - glDisable (GL_BLEND); - glDisable (GL_TEXTURE_1D); -} - -static int compareslinks (const void *l, const void *r) -{ - struct slink const *ls = l; - struct slink const *rs = r; - if (ls->bbox.y0 == rs->bbox.y0) { - return ls->bbox.x0 - rs->bbox.x0; - } - return ls->bbox.y0 - rs->bbox.y0; -} - -static void droptext (struct page *page) -{ - if (page->text) { - fz_drop_stext_page (state.ctx, page->text); - page->fmark = NULL; - page->lmark = NULL; - page->text = NULL; - } -} - -static void dropannots (struct page *page) -{ - if (page->annots) { - free (page->annots); - page->annots = NULL; - page->annotcount = 0; - } -} - -static void ensureannots (struct page *page) -{ - int i, count = 0; - pdf_annot *annot; - pdf_document *pdf; - pdf_page *pdfpage; - - pdf = pdf_specifics (state.ctx, state.doc); - if (!pdf) { - return; - } - - pdfpage = pdf_page_from_fz_page (state.ctx, page->fzpage); - if (state.gen != page->agen) { - dropannots (page); - page->agen = state.gen; - } - if (page->annots) { - return; - } - - for (annot = pdf_first_annot (state.ctx, pdfpage); - annot; - annot = pdf_next_annot (state.ctx, annot)) { - count++; - } - - if (count > 0) { - page->annotcount = count; - page->annots = calloc (count, sizeof (*page->annots)); - if (!page->annots) { - err (1, errno, "calloc annots %d", count); - } - - for (annot = pdf_first_annot (state.ctx, pdfpage), i = 0; - annot; - annot = pdf_next_annot (state.ctx, annot), i++) { - fz_rect rect; - - rect = pdf_bound_annot (state.ctx, annot); - page->annots[i].annot = annot; - page->annots[i].bbox = fz_round_rect (rect); - } - } -} - -static void dropslinks (struct page *page) -{ - if (page->slinks) { - free (page->slinks); - page->slinks = NULL; - page->slinkcount = 0; - } - if (page->links) { - fz_drop_link (state.ctx, page->links); - page->links = NULL; - } -} - -static void ensureslinks (struct page *page) -{ - fz_matrix ctm; - int i, count; - size_t slinksize = sizeof (*page->slinks); - fz_link *link; - - ensureannots (page); - if (state.gen != page->sgen) { - dropslinks (page); - page->sgen = state.gen; - } - if (page->slinks) { - return; - } - - ensurelinks (page); - ctm = pagectm (page); - - count = page->annotcount; - for (link = page->links; link; link = link->next) { - count++; - } - if (count > 0) { - int j; - - page->slinkcount = count; - page->slinks = calloc (count, slinksize); - if (!page->slinks) { - err (1, errno, "calloc slinks %d", count); - } - - for (i = 0, link = page->links; link; ++i, link = link->next) { - fz_rect rect; - - rect = link->rect; - rect = fz_transform_rect (rect, ctm); - page->slinks[i].tag = SLINK; - page->slinks[i].u.link = link; - page->slinks[i].bbox = fz_round_rect (rect); - } - for (j = 0; j < page->annotcount; ++j, ++i) { - fz_rect rect; - rect = pdf_bound_annot (state.ctx, page->annots[j].annot); - rect = fz_transform_rect (rect, ctm); - page->slinks[i].bbox = fz_round_rect (rect); - - page->slinks[i].tag = SANNOT; - page->slinks[i].u.annot = page->annots[j].annot; - } - qsort (page->slinks, count, slinksize, compareslinks); - } -} - -static void highlightslinks (struct page *page, int xoff, int yoff, - int noff, const char *targ, unsigned int tlen, - const char *chars, unsigned int clen, int hfsize) -{ - char buf[40]; - struct slink *slink; - float x0, y0, x1, y1, w; - - ensureslinks (page); - glColor3ub (0xc3, 0xb0, 0x91); - for (int i = 0; i < page->slinkcount; ++i) { - fmt_linkn (buf, chars, clen, i + noff); - if (!tlen || !strncmp (targ, buf, tlen)) { - slink = &page->slinks[i]; - - x0 = slink->bbox.x0 + xoff - 5; - y1 = slink->bbox.y0 + yoff - 5; - y0 = y1 + 10 + hfsize; - w = measure_string (state.face, hfsize, buf); - x1 = x0 + w + 10; - recti ((int) x0, (int) y0, (int) x1, (int) y1); - } - } - - glEnable (GL_BLEND); - glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable (GL_TEXTURE_2D); - glColor3ub (0, 0, 0); - for (int i = 0; i < page->slinkcount; ++i) { - fmt_linkn (buf, chars, clen, i + noff); - if (!tlen || !strncmp (targ, buf, tlen)) { - slink = &page->slinks[i]; - - x0 = slink->bbox.x0 + xoff; - y0 = slink->bbox.y0 + yoff + hfsize; - draw_string (state.face, hfsize, x0, y0, buf); - } - } - glDisable (GL_TEXTURE_2D); - glDisable (GL_BLEND); -} - -static void uploadslice (struct tile *tile, struct slice *slice) -{ - int offset; - struct slice *slice1; - unsigned char *texdata; - - offset = 0; - for (slice1 = tile->slices; slice != slice1; slice1++) { - offset += slice1->h * tile->w * tile->pixmap->n; - } - if (slice->texindex != -1 && slice->texindex < state.tex.count - && state.tex.owners[slice->texindex].slice == slice) { - glBindTexture (TEXT_TYPE, state.tex.ids[slice->texindex]); - } - else { - int subimage = 0; - int texindex = state.tex.index++ % state.tex.count; - - if (state.tex.owners[texindex].w == tile->w) { - if (state.tex.owners[texindex].h >= slice->h) { - subimage = 1; - } - else { - state.tex.owners[texindex].h = slice->h; - } - } - else { - state.tex.owners[texindex].h = slice->h; - } - - state.tex.owners[texindex].w = tile->w; - state.tex.owners[texindex].slice = slice; - slice->texindex = texindex; - - glBindTexture (TEXT_TYPE, state.tex.ids[texindex]); -#if TEXT_TYPE == GL_TEXTURE_2D - glTexParameteri (TEXT_TYPE, GL_TEXTURE_MIN_FILTER, GL_NEAREST); - glTexParameteri (TEXT_TYPE, GL_TEXTURE_MAG_FILTER, GL_NEAREST); - glTexParameteri (TEXT_TYPE, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri (TEXT_TYPE, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); -#endif - texdata = tile->pixmap->samples; - if (subimage) { - glTexSubImage2D (TEXT_TYPE, 0, 0, 0, tile->w, slice->h, - state.tex.form, state.tex.ty, texdata+offset); - } - else { - glTexImage2D (TEXT_TYPE, 0, state.tex.iform, tile->w, slice->h, - 0, state.tex.form, state.tex.ty, texdata+offset); - } - } -} - -ML0 (begintiles (void)) -{ - glEnable (TEXT_TYPE); - glTexCoordPointer (2, GL_FLOAT, 0, state.texcoords); - glVertexPointer (2, GL_FLOAT, 0, state.vertices); -} - -ML0 (endtiles (void)) -{ - glDisable (TEXT_TYPE); -} - -ML0 (drawtile (value args_v, value ptr_v)) -{ - CAMLparam2 (args_v, ptr_v); - int dispx = Int_val (Field (args_v, 0)); - int dispy = Int_val (Field (args_v, 1)); - int dispw = Int_val (Field (args_v, 2)); - int disph = Int_val (Field (args_v, 3)); - int tilex = Int_val (Field (args_v, 4)); - int tiley = Int_val (Field (args_v, 5)); - struct tile *tile = parse_pointer (__func__, String_val (ptr_v)); - int slicey, firstslice; - struct slice *slice; - GLfloat *texcoords = state.texcoords; - GLfloat *vertices = state.vertices; - - firstslice = tiley / tile->sliceheight; - slice = &tile->slices[firstslice]; - slicey = tiley % tile->sliceheight; - - while (disph > 0) { - int dh; - - dh = slice->h - slicey; - dh = fz_mini (disph, dh); - uploadslice (tile, slice); - - texcoords[0] = tilex; texcoords[1] = slicey; - texcoords[2] = tilex+dispw; texcoords[3] = slicey; - texcoords[4] = tilex; texcoords[5] = slicey+dh; - texcoords[6] = tilex+dispw; texcoords[7] = slicey+dh; - - vertices[0] = dispx; vertices[1] = dispy; - vertices[2] = dispx+dispw; vertices[3] = dispy; - vertices[4] = dispx; vertices[5] = dispy+dh; - vertices[6] = dispx+dispw; vertices[7] = dispy+dh; - -#if TEXT_TYPE == GL_TEXTURE_2D - for (int i = 0; i < 8; ++i) { - texcoords[i] /= ((i & 1) == 0 ? tile->w : slice->h); - } -#endif - - glDrawArrays (GL_TRIANGLE_STRIP, 0, 4); - dispy += dh; - disph -= dh; - slice++; - ARSERT (!(slice - tile->slices >= tile->slicecount && disph > 0)); - slicey = 0; - } - CAMLreturn0; -} - -ML (postprocess (value ptr_v, value hlmask_v, - value xoff_v, value yoff_v, value li_v)) -{ - CAMLparam5 (ptr_v, hlmask_v, xoff_v, yoff_v, li_v); - int xoff = Int_val (xoff_v); - int yoff = Int_val (yoff_v); - int noff = Int_val (Field (li_v, 0)); - const char *targ = String_val (Field (li_v, 1)); - mlsize_t tlen = caml_string_length (Field (li_v, 1)); - int hfsize = Int_val (Field (li_v, 2)); - const char *chars = String_val (Field (li_v, 3)); - mlsize_t clen = caml_string_length (Field (li_v, 3)); - int hlmask = Int_val (hlmask_v); - struct page *page = parse_pointer (__func__, String_val (ptr_v)); - - if (!page->fzpage) { - /* deal with loadpage failed pages */ - goto done; - } - - if (trylock (__func__)) { - noff = -1; - goto done; - } - - ensureannots (page); - if (hlmask & 1) { - highlightlinks (page, xoff, yoff); - } - if (hlmask & 2) { - highlightslinks (page, xoff, yoff, noff, targ, STTI (tlen), - chars, STTI (clen), hfsize); - noff = page->slinkcount; - } - if (page->tgen == state.gen) { - showsel (page, xoff, yoff); - } - unlock (__func__); - - done: - CAMLreturn (Val_int (noff)); -} - -static struct annot *getannot (struct page *page, int x, int y) -{ - fz_point p; - fz_matrix ctm; - const fz_matrix *tctm; - pdf_document *pdf = pdf_specifics (state.ctx, state.doc); - - if (!page->annots) { - return NULL; - } - - if (pdf) { - trimctm (pdf_page_from_fz_page (state.ctx, page->fzpage), page->pdimno); - tctm = &state.pagedims[page->pdimno].tctm; - } - else { - tctm = &fz_identity; - } - - p.x = x; - p.y = y; - - ctm = fz_concat (*tctm, state.pagedims[page->pdimno].ctm); - ctm = fz_invert_matrix (ctm); - p = fz_transform_point (p, ctm); - - if (pdf) { - for (int i = 0; i < page->annotcount; ++i) { - struct annot *a = &page->annots[i]; - if (fz_is_point_inside_rect (p, pdf_bound_annot (state.ctx, - a->annot))) { - return a; - } - } - } - return NULL; -} - -static fz_link *getlink (struct page *page, int x, int y) -{ - fz_link *link; - fz_point p = { .x = x, .y = y }; - - ensureslinks (page); - p = fz_transform_point (p, fz_invert_matrix (pagectm (page))); - - for (link = page->links; link; link = link->next) { - if (fz_is_point_inside_rect (p, link->rect)) { - return link; - } - } - return NULL; -} - -static void ensuretext (struct page *page) -{ - if (state.gen != page->tgen) { - droptext (page); - page->tgen = state.gen; - } - if (!page->text) { - fz_device *tdev; - - page->text = fz_new_stext_page (state.ctx, - state.pagedims[page->pdimno].mediabox); - tdev = fz_new_stext_device (state.ctx, page->text, 0); - fz_run_display_list (state.ctx, page->dlist, - tdev, pagectm (page), fz_infinite_rect, NULL); - fz_close_device (state.ctx, tdev); - fz_drop_device (state.ctx, tdev); - } -} - -ML (find_page_with_links (value start_page_v, value dir_v)) -{ - CAMLparam2 (start_page_v, dir_v); - CAMLlocal1 (ret_v); - int i, dir = Int_val (dir_v); - int start_page = Int_val (start_page_v); - int end_page = dir > 0 ? state.pagecount : -1; - pdf_document *pdf; - - fz_var (i); - fz_var (end_page); - ret_v = Val_int (0); - lock (__func__); - pdf = pdf_specifics (state.ctx, state.doc); - for (i = start_page + dir; i != end_page; i += dir) { - int found; - - fz_var (found); - if (pdf) { - pdf_page *page = NULL; - - fz_var (page); - fz_try (state.ctx) { - page = pdf_load_page (state.ctx, pdf, i); - found = !!page->links || !!page->annots; - } - fz_catch (state.ctx) { - found = 0; - } - fz_drop_page (state.ctx, &page->super); - } - else { - fz_page *page = fz_load_page (state.ctx, state.doc, i); - fz_link *link = fz_load_links (state.ctx, page); - found = !!link; - fz_drop_link (state.ctx, link); - fz_drop_page (state.ctx, page); - } - - if (found) { - ret_v = caml_alloc_small (1, 1); - Field (ret_v, 0) = Val_int (i); - goto unlock; - } - } - unlock: - unlock (__func__); - CAMLreturn (ret_v); -} - -ML (findlink (value ptr_v, value dir_v)) -{ - CAMLparam2 (ptr_v, dir_v); - CAMLlocal2 (ret_v, pos_v); - struct page *page; - int dirtag, i, slinkindex; - struct slink *found = NULL ,*slink; - - page = parse_pointer (__func__, String_val (ptr_v)); - ret_v = Val_int (0); - lock (__func__); - ensureslinks (page); - - if (Is_block (dir_v)) { - dirtag = Tag_val (dir_v); - switch (dirtag) { - case LDfirstvisible: - { - int x0, y0, dir, first_index, last_index; - - pos_v = Field (dir_v, 0); - x0 = Int_val (Field (pos_v, 0)); - y0 = Int_val (Field (pos_v, 1)); - dir = Int_val (Field (pos_v, 2)); - - if (dir >= 0) { - dir = 1; - first_index = 0; - last_index = page->slinkcount; - } - else { - first_index = page->slinkcount - 1; - last_index = -1; - } - - for (i = first_index; i != last_index; i += dir) { - slink = &page->slinks[i]; - if (slink->bbox.y0 >= y0 && slink->bbox.x0 >= x0) { - found = slink; - break; - } - } - } - break; - - case LDleft: - slinkindex = Int_val (Field (dir_v, 0)); - found = &page->slinks[slinkindex]; - for (i = slinkindex - 1; i >= 0; --i) { - slink = &page->slinks[i]; - if (slink->bbox.x0 < found->bbox.x0) { - found = slink; - break; - } - } - break; - - case LDright: - slinkindex = Int_val (Field (dir_v, 0)); - found = &page->slinks[slinkindex]; - for (i = slinkindex + 1; i < page->slinkcount; ++i) { - slink = &page->slinks[i]; - if (slink->bbox.x0 > found->bbox.x0) { - found = slink; - break; - } - } - break; - - case LDdown: - slinkindex = Int_val (Field (dir_v, 0)); - found = &page->slinks[slinkindex]; - for (i = slinkindex + 1; i < page->slinkcount; ++i) { - slink = &page->slinks[i]; - if (slink->bbox.y0 >= found->bbox.y0) { - found = slink; - break; - } - } - break; - - case LDup: - slinkindex = Int_val (Field (dir_v, 0)); - found = &page->slinks[slinkindex]; - for (i = slinkindex - 1; i >= 0; --i) { - slink = &page->slinks[i]; - if (slink->bbox.y0 <= found->bbox.y0) { - found = slink; - break; - } - } - break; - } - } - else { - dirtag = Int_val (dir_v); - switch (dirtag) { - case LDfirst: - found = page->slinks; - break; - - case LDlast: - if (page->slinks) { - found = page->slinks + (page->slinkcount - 1); - } - break; - } - } - if (found) { - ret_v = caml_alloc_small (2, 1); - Field (ret_v, 0) = Val_int (found - page->slinks); - } - - unlock (__func__); - CAMLreturn (ret_v); -} - -ML (getlink (value ptr_v, value n_v)) -{ - CAMLparam2 (ptr_v, n_v); - CAMLlocal4 (ret_v, tup_v, str_v, gr_v); - int n = Int_val (n_v); - fz_link *link; - struct page *page; - struct slink *slink; - - ret_v = Val_int (0); - page = parse_pointer (__func__, String_val (ptr_v)); - - lock (__func__); - ensureslinks (page); - if (!page->slinkcount || n > page->slinkcount) goto unlock; - slink = &page->slinks[n]; - if (slink->tag == SLINK) { - link = slink->u.link; - str_v = caml_copy_string (link->uri); - ret_v = caml_alloc_small (1, Uuri); - Field (ret_v, 0) = str_v; - } - else { - int ty = pdf_annot_type (state.ctx, slink->u.annot) - == PDF_ANNOT_FILE_ATTACHMENT ? Ufileannot : Utextannot; - - ret_v = caml_alloc_small (1, ty); - tup_v = caml_alloc_tuple (2); - Field (ret_v, 0) = tup_v; - Field (tup_v, 0) = ptr_v; - Field (tup_v, 1) = n_v; - } -unlock: - unlock (__func__); - CAMLreturn (ret_v); -} - -ML (getlinkn (value ptr_v, value c_v, value n_v, value noff_v)) -{ - CAMLparam4 (ptr_v, c_v, n_v, noff_v); - CAMLlocal1 (ret_v); - char buf[40]; - struct page *page; - const char *c = String_val (c_v); - const char *n = String_val (n_v); - mlsize_t clen = caml_string_length (c_v); - page = parse_pointer (__func__, String_val (ptr_v)); - - lock (__func__); - ensureslinks (page); - - ret_v = Val_int (-page->slinkcount); - for (int i = 0; i < page->slinkcount; ++i) { - fmt_linkn (buf, c, STTI (clen), i - Int_val (noff_v)); - if (!strncmp (buf, n, clen)) { - ret_v = Val_int (i+1); - break; - } - } - - unlock (__func__); - CAMLreturn (ret_v); -} - -ML (gettextannot (value ptr_v, value n_v)) -{ - CAMLparam2 (ptr_v, n_v); - CAMLlocal1 (ret_v); - pdf_document *pdf; - const char *contents = ""; - - lock (__func__); - pdf = pdf_specifics (state.ctx, state.doc); - if (pdf) { - struct page *page; - pdf_annot *annot; - struct slink *slink; - - page = parse_pointer (__func__, String_val (ptr_v)); - slink = &page->slinks[Int_val (n_v)]; - annot = slink->u.annot; - contents = pdf_annot_contents (state.ctx, annot); - } - unlock (__func__); - ret_v = caml_copy_string (contents); - CAMLreturn (ret_v); -} - -ML (getfileannot (value ptr_v, value n_v)) -{ - CAMLparam2 (ptr_v, n_v); - CAMLlocal1 (ret_v); - - lock (__func__); - - struct page *page = parse_pointer (__func__, String_val (ptr_v)); - struct slink *slink = &page->slinks[Int_val (n_v)]; - pdf_obj *fs = pdf_dict_get (state.ctx, - pdf_annot_obj (state.ctx, slink->u.annot), - PDF_NAME (FS)); - ret_v = caml_copy_string (pdf_embedded_file_name (state.ctx, fs)); - - unlock (__func__); - CAMLreturn (ret_v); -} - -ML0 (savefileannot (value ptr_v, value n_v, value path_v)) -{ - CAMLparam3 (ptr_v, n_v, path_v); - struct page *page = parse_pointer (__func__, String_val (ptr_v)); - const char *path = String_val (path_v); - - lock (__func__); - struct slink *slink = &page->slinks[Int_val (n_v)]; - fz_try (state.ctx) { - pdf_obj *fs = pdf_dict_get (state.ctx, - pdf_annot_obj (state.ctx, slink->u.annot), - PDF_NAME (FS)); - fz_buffer *buf = pdf_load_embedded_file (state.ctx, fs); - fz_save_buffer (state.ctx, buf, path); - fz_drop_buffer (state.ctx, buf); - printd ("progress 1 saved '%s'", path); - } - fz_catch (state.ctx) { - printd ("emsg saving '%s': %s", path, fz_caught_message (state.ctx)); - } - unlock (__func__); -} - -ML (getlinkrect (value ptr_v, value n_v)) -{ - CAMLparam2 (ptr_v, n_v); - CAMLlocal1 (ret_v); - struct page *page; - struct slink *slink; - - page = parse_pointer (__func__, String_val (ptr_v)); - ret_v = caml_alloc_tuple (4); - lock (__func__); - ensureslinks (page); - - slink = &page->slinks[Int_val (n_v)]; - Field (ret_v, 0) = Val_int (slink->bbox.x0); - Field (ret_v, 1) = Val_int (slink->bbox.y0); - Field (ret_v, 2) = Val_int (slink->bbox.x1); - Field (ret_v, 3) = Val_int (slink->bbox.y1); - unlock (__func__); - CAMLreturn (ret_v); -} - -ML (whatsunder (value ptr_v, value x_v, value y_v)) -{ - CAMLparam3 (ptr_v, x_v, y_v); - CAMLlocal4 (ret_v, tup_v, str_v, gr_v); - fz_link *link; - struct annot *annot; - struct page *page; - const char *ptr = String_val (ptr_v); - int x = Int_val (x_v), y = Int_val (y_v); - struct pagedim *pdim; - - ret_v = Val_int (0); - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, ptr); - pdim = &state.pagedims[page->pdimno]; - x += pdim->bounds.x0; - y += pdim->bounds.y0; - - annot = getannot (page, x, y); - if (annot) { - int i, n = -1, ty; - - ensureslinks (page); - for (i = 0; i < page->slinkcount; ++i) { - if (page->slinks[i].tag == SANNOT - && page->slinks[i].u.annot == annot->annot) { - n = i; - break; - } - } - ty = pdf_annot_type (state.ctx, annot->annot) - == PDF_ANNOT_FILE_ATTACHMENT ? Ufileannot : Utextannot; - - ret_v = caml_alloc_small (1, ty); - tup_v = caml_alloc_tuple (2); - Field (ret_v, 0) = tup_v; - Field (tup_v, 0) = ptr_v; - Field (tup_v, 1) = Int_val (n); - goto unlock; - } - - link = getlink (page, x, y); - if (link) { - str_v = caml_copy_string (link->uri); - ret_v = caml_alloc_small (1, Uuri); - Field (ret_v, 0) = str_v; - } - else { - fz_stext_block *block; - fz_point p = { .x = x, .y = y }; - - ensuretext (page); - - for (block = page->text->first_block; block; block = block->next) { - fz_stext_line *line; - - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - if (!fz_is_point_inside_rect (p, block->bbox)) { - continue; - } - - for (line = block->u.t.first_line; line; line = line->next) { - fz_stext_char *ch; - - if (!fz_is_point_inside_rect (p, line->bbox)) { - continue; - } - - for (ch = line->first_char; ch; ch = ch->next) { - if (!fz_is_point_inside_quad (p, ch->quad)) { - const char *n2 = fz_font_name (state.ctx, ch->font); - FT_FaceRec *face = fz_font_ft_face (state.ctx, - ch->font); - - if (!n2) { - n2 = ""; - } - - if (face && face->family_name) { - char *s; - char *n1 = face->family_name; - size_t l1 = strlen (n1); - size_t l2 = strlen (n2); - - if (l1 != l2 || memcmp (n1, n2, l1)) { - s = malloc (l1 + l2 + 2); - if (s) { - memcpy (s, n2, l2); - s[l2] = '='; - memcpy (s + l2 + 1, n1, l1 + 1); - str_v = caml_copy_string (s); - free (s); - } - } - } - if (str_v == Val_unit) { - str_v = caml_copy_string (n2); - } - ret_v = caml_alloc_small (1, Utext); - Field (ret_v, 0) = str_v; - goto unlock; - } - } - } - } - } -unlock: - unlock (__func__); - -done: - CAMLreturn (ret_v); -} - -ML0 (clearmark (value ptr_v)) -{ - CAMLparam1 (ptr_v); - struct page *page; - - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, String_val (ptr_v)); - page->fmark = NULL; - page->lmark = NULL; - - unlock (__func__); - done: - CAMLreturn0; -} - -static int uninteresting (int c) -{ - return isspace (c) || ispunct (c); -} - -ML (markunder (value ptr_v, value x_v, value y_v, value mark_v)) -{ - CAMLparam4 (ptr_v, x_v, y_v, mark_v); - CAMLlocal1 (ret_v); - struct page *page; - fz_stext_line *line; - fz_stext_block *block; - struct pagedim *pdim; - int mark = Int_val (mark_v); - fz_point p = { .x = Int_val (x_v), .y = Int_val (y_v) }; - - ret_v = Val_bool (0); - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, String_val (ptr_v)); - pdim = &state.pagedims[page->pdimno]; - - ensuretext (page); - - if (mark == MarkPage) { - page->fmark = page->text->first_block->u.t.first_line->first_char; - page->lmark = page->text->last_block->u.t.last_line->last_char; - ret_v = Val_bool (1); - goto unlock; - } - - p.x += pdim->bounds.x0; - p.y += pdim->bounds.y0; - - for (block = page->text->first_block; block; block = block->next) { - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - if (!fz_is_point_inside_rect (p, block->bbox)) { - continue; - } - - if (mark == MarkBlock) { - page->fmark = block->u.t.first_line->first_char; - page->lmark = block->u.t.last_line->last_char; - ret_v = Val_bool (1); - goto unlock; - } - - for (line = block->u.t.first_line; line; line = line->next) { - fz_stext_char *ch; - - if (!fz_is_point_inside_rect (p, line->bbox)) { - continue; - } - - if (mark == MarkLine) { - page->fmark = line->first_char; - page->lmark = line->last_char; - ret_v = Val_bool (1); - goto unlock; - } - - for (ch = line->first_char; ch; ch = ch->next) { - fz_stext_char *ch2, *first = NULL, *last = NULL; - - if (fz_is_point_inside_quad (p, ch->quad)) { - for (ch2 = line->first_char; ch2 != ch; ch2 = ch2->next) { - if (uninteresting (ch2->c)) { - first = NULL; - } - else { - if (!first) { - first = ch2; - } - } - } - for (ch2 = ch; ch2; ch2 = ch2->next) { - if (uninteresting (ch2->c)) { - break; - } - last = ch2; - } - - page->fmark = first; - page->lmark = last; - ret_v = Val_bool (1); - goto unlock; - } - } - } - } -unlock: - if (!Bool_val (ret_v)) { - page->fmark = NULL; - page->lmark = NULL; - } - unlock (__func__); - -done: - CAMLreturn (ret_v); -} - -ML (rectofblock (value ptr_v, value x_v, value y_v)) -{ - CAMLparam3 (ptr_v, x_v, y_v); - CAMLlocal2 (ret_v, res_v); - fz_rect *b = NULL; - struct page *page; - struct pagedim *pdim; - fz_stext_block *block; - fz_point p = { .x = Int_val (x_v), .y = Int_val (y_v) }; - - ret_v = Val_int (0); - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, String_val (ptr_v)); - pdim = &state.pagedims[page->pdimno]; - p.x += pdim->bounds.x0; - p.y += pdim->bounds.y0; - - ensuretext (page); - - for (block = page->text->first_block; block; block = block->next) { - switch (block->type) { - case FZ_STEXT_BLOCK_TEXT: - b = &block->bbox; - break; - - case FZ_STEXT_BLOCK_IMAGE: - b = &block->bbox; - break; - - default: - continue; - } - - if (fz_is_point_inside_rect (p, *b)) { - break; - } - b = NULL; - } - if (b) { - res_v = caml_alloc_small (4 * Double_wosize, Double_array_tag); - ret_v = caml_alloc_small (1, 1); - Store_double_field (res_v, 0, (double) b->x0); - Store_double_field (res_v, 1, (double) b->x1); - Store_double_field (res_v, 2, (double) b->y0); - Store_double_field (res_v, 3, (double) b->y1); - Field (ret_v, 0) = res_v; - } - unlock (__func__); - - done: - CAMLreturn (ret_v); -} - -ML0 (seltext (value ptr_v, value rect_v)) -{ - CAMLparam2 (ptr_v, rect_v); - struct page *page; - struct pagedim *pdim; - int x0, x1, y0, y1; - fz_stext_char *ch; - fz_stext_line *line; - fz_stext_block *block; - fz_stext_char *fc, *lc; - - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, String_val (ptr_v)); - ensuretext (page); - - pdim = &state.pagedims[page->pdimno]; - x0 = Int_val (Field (rect_v, 0)) + pdim->bounds.x0; - y0 = Int_val (Field (rect_v, 1)) + pdim->bounds.y0; - x1 = Int_val (Field (rect_v, 2)) + pdim->bounds.x0; - y1 = Int_val (Field (rect_v, 3)) + pdim->bounds.y0; - - if (y0 > y1) { - int t = y0; - y0 = y1; - y1 = t; - x0 = x1; - x1 = t; - } - - fc = page->fmark; - lc = page->lmark; - - for (block = page->text->first_block; block; block = block->next) { - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - - for (line = block->u.t.first_line; line; line = line->next) { - for (ch = line->first_char; ch; ch = ch->next) { - fz_point p0 = { .x = x0, .y = y0 }, p1 = { .x = x1, .y = y1 }; - if (fz_is_point_inside_quad (p0, ch->quad)) { - fc = ch; - } - if (fz_is_point_inside_quad (p1, ch->quad)) { - lc = ch; - } - } - } - } - if (x1 < x0 && fc == lc) { - fz_stext_char *t; - - t = fc; - fc = lc; - lc = t; - } - - page->fmark = fc; - page->lmark = lc; - - unlock (__func__); - - done: - CAMLreturn0; -} - -static int pipechar (FILE *f, fz_stext_char *ch) -{ - char buf[4]; - int len; - size_t ret; - - len = fz_runetochar (buf, ch->c); - ret = fwrite (buf, len, 1, f); - if (ret != 1) { - printd ("emsg failed to fwrite %d bytes ret=%zu: %d(%s)", - len, ret, errno, strerror (errno)); - return -1; - } - return 0; -} - -ML (spawn (value command_v, value fds_v)) -{ - CAMLparam2 (command_v, fds_v); - CAMLlocal2 (l_v, tup_v); - int ret, ret1; - pid_t pid = (pid_t) -1; - char *msg = NULL; - value earg_v = Nothing; - posix_spawnattr_t attr; - posix_spawn_file_actions_t fa; - char *argv[] = { "/bin/sh", "-c", NULL, NULL }; - - argv[2] = &Byte (command_v, 0); - if ((ret = posix_spawn_file_actions_init (&fa)) != 0) { - unix_error (ret, "posix_spawn_file_actions_init", Nothing); - } - - if ((ret = posix_spawnattr_init (&attr)) != 0) { - msg = "posix_spawnattr_init"; - goto fail1; - } - -#ifdef POSIX_SPAWN_USEVFORK - if ((ret = posix_spawnattr_setflags (&attr, POSIX_SPAWN_USEVFORK)) != 0) { - msg = "posix_spawnattr_setflags POSIX_SPAWN_USEVFORK"; - goto fail; - } -#endif - - for (l_v = fds_v; l_v != Val_int (0); l_v = Field (l_v, 1)) { - int fd1, fd2; - - tup_v = Field (l_v, 0); - fd1 = Int_val (Field (tup_v, 0)); - fd2 = Int_val (Field (tup_v, 1)); - if (fd2 < 0) { - if ((ret = posix_spawn_file_actions_addclose (&fa, fd1)) != 0) { - msg = "posix_spawn_file_actions_addclose"; - earg_v = tup_v; - goto fail; - } - } - else { - if ((ret = posix_spawn_file_actions_adddup2 (&fa, fd1, fd2)) != 0) { - msg = "posix_spawn_file_actions_adddup2"; - earg_v = tup_v; - goto fail; - } - } - } - - extern char **environ; - if ((ret = posix_spawn (&pid, "/bin/sh", &fa, &attr, argv, environ))) { - msg = "posix_spawn"; - goto fail; - } - - fail: - if ((ret1 = posix_spawnattr_destroy (&attr)) != 0) { - printd ("emsg posix_spawnattr_destroy: %d(%s)", ret1, strerror (ret1)); - } - - fail1: - if ((ret1 = posix_spawn_file_actions_destroy (&fa)) != 0) { - printd ("emsg posix_spawn_file_actions_destroy: %d(%s)", - ret1, strerror (ret1)); - } - - if (msg) { - unix_error (ret, msg, earg_v); - } - - CAMLreturn (Val_int (pid)); -} - -ML (hassel (value ptr_v)) -{ - CAMLparam1 (ptr_v); - CAMLlocal1 (ret_v); - struct page *page; - - ret_v = Val_bool (0); - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, String_val (ptr_v)); - ret_v = Val_bool (page->fmark && page->lmark); - unlock (__func__); - done: - CAMLreturn (ret_v); -} - -ML0 (copysel (value fd_v, value ptr_v)) -{ - CAMLparam2 (fd_v, ptr_v); - FILE *f; - int seen = 0; - struct page *page; - fz_stext_line *line; - fz_stext_block *block; - int fd = Int_val (fd_v); - - if (trylock (__func__)) { - goto done; - } - - page = parse_pointer (__func__, String_val (ptr_v)); - - if (!page->fmark || !page->lmark) { - printd ("emsg nothing to copy on page %d", page->pageno); - goto unlock; - } - - f = fdopen (fd, "w"); - if (!f) { - printd ("emsg failed to fdopen sel pipe (from fd %d): %d(%s)", - fd, errno, strerror (errno)); - f = stdout; - } - - for (block = page->text->first_block; block; block = block->next) { - if (block->type != FZ_STEXT_BLOCK_TEXT) { - continue; - } - - for (line = block->u.t.first_line; line; line = line->next) { - fz_stext_char *ch; - for (ch = line->first_char; ch; ch = ch->next) { - if (seen || ch == page->fmark) { - do { - if (pipechar (f, ch)) { - goto close; - } - if (ch == page->lmark) { - goto close; - } - } while ((ch = ch->next)); - seen = 1; - break; - } - } - if (seen) { - fputc ('\n', f); - } - } - } -close: - if (f != stdout) { - int ret = fclose (f); - fd = -1; - if (ret == -1) { - if (errno != ECHILD) { - printd ("emsg failed to close sel pipe: %d(%s)", - errno, strerror (errno)); - } - } - } -unlock: - unlock (__func__); - -done: - if (fd >= 0) { - if (close (fd)) { - printd ("emsg failed to close sel pipe: %d(%s)", - errno, strerror (errno)); - } - } - CAMLreturn0; -} - -ML (getpdimrect (value pagedimno_v)) -{ - CAMLparam1 (pagedimno_v); - CAMLlocal1 (ret_v); - int pagedimno = Int_val (pagedimno_v); - fz_rect box; - - ret_v = caml_alloc_small (4 * Double_wosize, Double_array_tag); - if (trylock (__func__)) { - box = fz_empty_rect; - } - else { - box = state.pagedims[pagedimno].mediabox; - unlock (__func__); - } - - Store_double_field (ret_v, 0, (double) box.x0); - Store_double_field (ret_v, 1, (double) box.x1); - Store_double_field (ret_v, 2, (double) box.y0); - Store_double_field (ret_v, 3, (double) box.y1); - - CAMLreturn (ret_v); -} - -ML (zoom_for_height (value winw_v, value winh_v, value dw_v, value cols_v)) -{ - CAMLparam4 (winw_v, winh_v, dw_v, cols_v); - CAMLlocal1 (ret_v); - int i; - float zoom = -1.; - float maxh = 0.0; - struct pagedim *p; - float winw = Int_val (winw_v); - float winh = Int_val (winh_v); - float dw = Int_val (dw_v); - float cols = Int_val (cols_v); - float pw = 1.0, ph = 1.0; - - if (trylock (__func__)) { - goto done; - } - - for (i = 0, p = state.pagedims; i < state.pagedimcount; ++i, ++p) { - float w = p->pagebox.x1 / cols; - float h = p->pagebox.y1; - if (h > maxh) { - maxh = h; - ph = h; - if (state.fitmodel != FitProportional) { - pw = w; - } - } - if ((state.fitmodel == FitProportional) && w > pw) { - pw = w; - } - } - - zoom = (((winh / ph) * pw) + dw) / winw; - unlock (__func__); - done: - ret_v = caml_copy_double ((double) zoom); - CAMLreturn (ret_v); -} - -ML (getmaxw (value unit_v)) -{ - CAMLparam1 (unit_v); - CAMLlocal1 (ret_v); - int i; - float maxw = -1.; - struct pagedim *p; - - if (trylock (__func__)) { - goto done; - } - - for (i = 0, p = state.pagedims; i < state.pagedimcount; ++i, ++p) { - maxw = fz_max (maxw, p->pagebox.x1); - } - - unlock (__func__); - done: - ret_v = caml_copy_double ((double) maxw); - CAMLreturn (ret_v); -} - -ML (draw_string (value pt_v, value x_v, value y_v, value string_v)) -{ - CAMLparam4 (pt_v, x_v, y_v, string_v); - CAMLlocal1 (ret_v); - float w = draw_string (state.face, - Int_val (pt_v), Int_val (x_v), Int_val (y_v), - String_val (string_v)); - ret_v = caml_copy_double (w); - CAMLreturn (ret_v); -} - -ML (measure_string (value pt_v, value string_v)) -{ - CAMLparam2 (pt_v, string_v); - CAMLlocal1 (ret_v); - - ret_v = caml_copy_double ( - measure_string (state.face, Int_val (pt_v), String_val (string_v)) - ); - CAMLreturn (ret_v); -} - -ML (getpagebox (value ptr_v)) -{ - CAMLparam1 (ptr_v); - CAMLlocal1 (ret_v); - fz_rect rect; - fz_irect bbox; - fz_device *dev; - struct page *page = parse_pointer (__func__, String_val (ptr_v)); - - ret_v = caml_alloc_tuple (4); - dev = fz_new_bbox_device (state.ctx, &rect); - - fz_run_page (state.ctx, page->fzpage, dev, pagectm (page), NULL); - - fz_close_device (state.ctx, dev); - fz_drop_device (state.ctx, dev); - bbox = fz_round_rect (rect); - Field (ret_v, 0) = Val_int (bbox.x0); - Field (ret_v, 1) = Val_int (bbox.y0); - Field (ret_v, 2) = Val_int (bbox.x1); - Field (ret_v, 3) = Val_int (bbox.y1); - - CAMLreturn (ret_v); -} - -ML0 (setaalevel (value level_v)) -{ - CAMLparam1 (level_v); - - state.aalevel = Int_val (level_v); - CAMLreturn0; -} - -ML0 (setpapercolor (value rgba_v)) -{ - CAMLparam1 (rgba_v); - - state.papercolor[0] = (float) Double_val (Field (rgba_v, 0)); - state.papercolor[1] = (float) Double_val (Field (rgba_v, 1)); - state.papercolor[2] = (float) Double_val (Field (rgba_v, 2)); - state.papercolor[3] = (float) Double_val (Field (rgba_v, 3)); - CAMLreturn0; -} - -value ml_keysymtoutf8 (value keysym_v); -#ifndef MACOS -value ml_keysymtoutf8 (value keysym_v) -{ - CAMLparam1 (keysym_v); - CAMLlocal1 (str_v); - unsigned short keysym = (unsigned short) Int_val (keysym_v); - Rune rune; - extern long keysym2ucs (unsigned short); - int len; - char buf[5]; - - rune = (Rune) keysym2ucs (keysym); - len = fz_runetochar (buf, rune); - buf[len] = 0; - str_v = caml_copy_string (buf); - CAMLreturn (str_v); -} -#else -value ml_keysymtoutf8 (value keysym_v) -{ - CAMLparam1 (keysym_v); - CAMLlocal1 (str_v); - long ucs = Long_val (keysym_v); - int len; - char buf[5]; - - len = fz_runetochar (buf, (int) ucs); - buf[len] = 0; - str_v = caml_copy_string (buf); - CAMLreturn (str_v); -} -#endif - -ML (unproject (value ptr_v, value x_v, value y_v)) -{ - CAMLparam3 (ptr_v, x_v, y_v); - CAMLlocal2 (ret_v, tup_v); - struct page *page; - int x = Int_val (x_v), y = Int_val (y_v); - struct pagedim *pdim; - fz_point p; - - page = parse_pointer (__func__, String_val (ptr_v)); - pdim = &state.pagedims[page->pdimno]; - - ret_v = Val_int (0); - if (trylock (__func__)) { - goto done; - } - - p.x = x + pdim->bounds.x0; - p.y = y + pdim->bounds.y0; - - p = fz_transform_point (p, fz_invert_matrix (fz_concat (pdim->tctm, - pdim->ctm))); - - tup_v = caml_alloc_tuple (2); - ret_v = caml_alloc_small (1, 1); - Field (tup_v, 0) = Val_int (p.x); - Field (tup_v, 1) = Val_int (p.y); - Field (ret_v, 0) = tup_v; - - unlock (__func__); - done: - CAMLreturn (ret_v); -} - -ML (project (value ptr_v, value pageno_v, value pdimno_v, value x_v, value y_v)) -{ - CAMLparam5 (ptr_v, pageno_v, pdimno_v, x_v, y_v); - CAMLlocal1 (ret_v); - struct page *page; - const char *s = String_val (ptr_v); - int pageno = Int_val (pageno_v); - int pdimno = Int_val (pdimno_v); - float x = (float) Double_val (x_v), y = (float) Double_val (y_v); - struct pagedim *pdim; - fz_point p; - fz_matrix ctm; - - ret_v = Val_int (0); - lock (__func__); - - if (!*s) { - page = loadpage (pageno, pdimno); - } - else { - page = parse_pointer (__func__, String_val (ptr_v)); - } - pdim = &state.pagedims[pdimno]; - - if (pdf_specifics (state.ctx, state.doc)) { - trimctm (pdf_page_from_fz_page (state.ctx, page->fzpage), page->pdimno); - ctm = state.pagedims[page->pdimno].tctm; - } - else { - ctm = fz_identity; - } - - p.x = x + pdim->bounds.x0; - p.y = y + pdim->bounds.y0; - - ctm = fz_concat (pdim->tctm, pdim->ctm); - p = fz_transform_point (p, ctm); - - ret_v = caml_alloc_tuple (2); - Field (ret_v, 0) = caml_copy_double ((double) p.x); - Field (ret_v, 1) = caml_copy_double ((double) p.y); - - if (!*s) { - freepage (page); - } - unlock (__func__); - CAMLreturn (ret_v); -} - -ML0 (addannot (value ptr_v, value x_v, value y_v, value contents_v)) -{ - CAMLparam4 (ptr_v, x_v, y_v, contents_v); - pdf_document *pdf = pdf_specifics (state.ctx, state.doc); - - if (pdf) { - pdf_annot *annot; - struct page *page; - fz_rect r; - - page = parse_pointer (__func__, String_val (ptr_v)); - annot = pdf_create_annot (state.ctx, - pdf_page_from_fz_page (state.ctx, - page->fzpage), - PDF_ANNOT_TEXT); - r.x0 = Int_val (x_v) - 10; - r.y0 = Int_val (y_v) - 10; - r.x1 = r.x0 + 20; - r.y1 = r.y0 + 20; - pdf_set_annot_contents (state.ctx, annot, String_val (contents_v)); - pdf_set_annot_rect (state.ctx, annot, r); - - state.dirty = 1; - } - CAMLreturn0; -} - -ML0 (delannot (value ptr_v, value n_v)) -{ - CAMLparam2 (ptr_v, n_v); - pdf_document *pdf = pdf_specifics (state.ctx, state.doc); - - if (pdf) { - struct page *page; - struct slink *slink; - - page = parse_pointer (__func__, String_val (ptr_v)); - slink = &page->slinks[Int_val (n_v)]; - pdf_delete_annot (state.ctx, - pdf_page_from_fz_page (state.ctx, page->fzpage), - (pdf_annot *) slink->u.annot); - state.dirty = 1; - } - CAMLreturn0; -} - -ML0 (modannot (value ptr_v, value n_v, value str_v)) -{ - CAMLparam3 (ptr_v, n_v, str_v); - pdf_document *pdf = pdf_specifics (state.ctx, state.doc); - - if (pdf) { - struct page *page; - struct slink *slink; - - page = parse_pointer (__func__, String_val (ptr_v)); - slink = &page->slinks[Int_val (n_v)]; - pdf_set_annot_contents (state.ctx, (pdf_annot *) slink->u.annot, - String_val (str_v)); - state.dirty = 1; - } - CAMLreturn0; -} - -ML (hasunsavedchanges (void)) -{ - return Val_bool (state.dirty); -} - -ML0 (savedoc (value path_v)) -{ - CAMLparam1 (path_v); - pdf_document *pdf = pdf_specifics (state.ctx, state.doc); - - if (pdf) { - pdf_save_document (state.ctx, pdf, String_val (path_v), NULL); - } - CAMLreturn0; -} - -static void makestippletex (void) -{ - const char pixels[] = "\xff\xff\0\0"; - glGenTextures (1, &state.stid); - glBindTexture (GL_TEXTURE_1D, state.stid); - glTexParameteri (GL_TEXTURE_1D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri (GL_TEXTURE_1D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); - glTexImage1D ( - GL_TEXTURE_1D, - 0, - GL_ALPHA, - 4, - 0, - GL_ALPHA, - GL_UNSIGNED_BYTE, - pixels - ); -} - -ML (fz_version (void)) -{ - return caml_copy_string (FZ_VERSION); -} - -ML (llpp_version (void)) -{ - extern char llpp_version[]; - return caml_copy_string (llpp_version); -} - -static void diag_callback (void *user, const char *message) -{ - if (pthread_equal (pthread_self (), state.thread)) { - printd ("emsg %s %s", (char *) user, message); - } - else { - puts (message); - } -} - -static fz_font *lsff (fz_context *ctx,int UNUSED_ATTR script, - int UNUSED_ATTR language, int UNUSED_ATTR serif, - int UNUSED_ATTR bold, int UNUSED_ATTR italic) -{ - static fz_font *font; - static int done; - - if (!done) { - char *path = getenv ("LLPP_FALLBACK_FONT"); - if (path) { - font = fz_new_font_from_file (ctx, NULL, path, 0, 1); - } - done = 1; - } - return font; -} - -ML0 (setdcf (value path_v)) -{ - free (state.dcf); - state.dcf = NULL; - const char *p = String_val (path_v); - if (*p) { - size_t len = caml_string_length (path_v); - state.dcf = malloc (len + 1); - if (!state.dcf) { - err (1, errno, "malloc dimpath %zu", len + 1); - } - memcpy (state.dcf, p, len); - state.dcf[len] = 0; - } -} - -ML (init (value csock_v, value params_v)) -{ - CAMLparam2 (csock_v, params_v); - CAMLlocal2 (trim_v, fuzz_v); - int ret, texcount, colorspace, mustoresize, redirstderr; - const char *fontpath; - const char *ext = TEXT_TYPE == GL_TEXTURE_2D - ? "texture_non_power_of_two" - : "texture_rectangle"; - - if (!strstr ((const char *) glGetString (GL_EXTENSIONS), ext)) { - errx (1, "OpenGL does not support '%s' extension", ext); - } - state.csock = Int_val (csock_v); - state.rotate = Int_val (Field (params_v, 0)); - state.fitmodel = Int_val (Field (params_v, 1)); - trim_v = Field (params_v, 2); - texcount = Int_val (Field (params_v, 3)); - state.sliceheight = Int_val (Field (params_v, 4)); - mustoresize = Int_val (Field (params_v, 5)); - colorspace = Int_val (Field (params_v, 6)); - fontpath = String_val (Field (params_v, 7)); - redirstderr = Bool_val (Field (params_v, 8)); - - if (redirstderr) { - if (pipe (state.pfds)) { - err (1, errno, "pipe"); - } - for (int ntries = 0; ntries < 1737; ++ntries) { - if (-1 == dup2 (state.pfds[1], 2)) { - if (EINTR == errno) { - continue; - } - err (1, errno, "dup2"); - } - break; - } - } else { - state.pfds[0] = 0; - state.pfds[1] = 0; - } - -#ifdef MACOS - state.utf8cs = 1; -#else - /* http://www.cl.cam.ac.uk/~mgk25/unicode.html */ - if (setlocale (LC_CTYPE, "")) { - const char *cset = nl_langinfo (CODESET); - state.utf8cs = !strcmp (cset, "UTF-8"); - } - else { - err (1, errno, "setlocale"); - } -#endif - - state.ctx = fz_new_context (NULL, NULL, mustoresize); - fz_register_document_handlers (state.ctx); - if (redirstderr) { - fz_set_error_callback (state.ctx, diag_callback, "[e]"); - fz_set_warning_callback (state.ctx, diag_callback, "[w]"); - } - fz_install_load_system_font_funcs (state.ctx, NULL, NULL, lsff); - - state.trimmargins = Bool_val (Field (trim_v, 0)); - fuzz_v = Field (trim_v, 1); - state.trimfuzz.x0 = Int_val (Field (fuzz_v, 0)); - state.trimfuzz.y0 = Int_val (Field (fuzz_v, 1)); - state.trimfuzz.x1 = Int_val (Field (fuzz_v, 2)); - state.trimfuzz.y1 = Int_val (Field (fuzz_v, 3)); - - set_tex_params (colorspace); - - if (*fontpath) { - state.face = load_font (fontpath); - } - else { - int len; - const unsigned char *data; - - data = pdf_lookup_substitute_font (state.ctx, 0, 0, 0, 0, &len); - state.face = load_builtin_font (data, len); - } - if (!state.face) { - _exit (1); - } - - realloctexts (texcount); - makestippletex (); - - ret = pthread_create (&state.thread, NULL, mainloop, NULL); - if (ret) { - errx (1, "pthread_create: %d(%s)", ret, strerror (ret)); - } - - CAMLreturn (Val_int (state.pfds[0])); -} diff --git a/main.ml b/main.ml deleted file mode 100644 index a2f439c..0000000 --- a/main.ml +++ /dev/null @@ -1,4897 +0,0 @@ -open Utils -open Config -open Uiutils - -module U = struct - let dopen = '\023' - let cs = '\024' - let freepage = '\025' - let freetile = '\026' - let search = '\027' - let geometry = '\028' - let reqlayout = '\029' - let page = '\030' - let tile = '\031' - let trimset = '\032' - let settrim = '\033' - let sliceh = '\034' - let interrupt = '\035' - let pgscale h = truncate (float h *. conf.pgscale) - let nogeomcmds = function | s, [] -> emptystr s | _ -> false - let maxy () = !S.maxy - if conf.maxhfit then !S.winh else 0 - let scalecolor c = let c = c *. conf.colorscale in (c, c, c) - let panbound x = bound x (- !S.w) !S.winw - let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout - let add_to_y_and_clamp inc = bound (!S.y + inc) 0 @@ maxy () -end - -let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) = - dolog {|rect { - x0,y0=(% f, % f) - x1,y1=(% f, % f) - x2,y2=(% f, % f) - x3,y3=(% f, % f) - }|} x0 y0 x1 y1 x2 y2 x3 y3 - -let hscrollh () = - if ((conf.scrollb land scrollbhv != 0) && (!S.w > !S.winw)) - || !S.uioh#alwaysscrolly - then conf.scrollbw - else 0 - -let setfontsize n = - fstate.fontsize <- n; - fstate.wwidth <- Ffi.measurestr fstate.fontsize "w"; - fstate.maxrows <- (!S.winh - fstate.fontsize - 1) / (fstate.fontsize + 1) - -let showtext c s = - S.text := Printf.sprintf "%c%s" c s; - Glutils.postRedisplay "showtext" - -let adderrmsg src msg = - Buffer.add_string S.errmsgs msg; - S.newerrmsgs := true; - Glutils.postRedisplay src - -let settextfmt fmt = Printf.kprintf (fun s -> S.text := s) fmt -let impmsg fmt = Printf.ksprintf (fun s -> showtext '!' s) fmt -let adderrfmt src fmt = Printf.ksprintf (fun s -> adderrmsg src s) fmt - -let launchpath () = - if emptystr conf.pathlauncher - then adderrmsg "path launcher" "command set" - else - let n = - match !S.layout with - | l :: _ -> string_of_int l.pageno - | _ -> E.s - in - let cmd = Str.global_replace Re.percents !S.path conf.pathlauncher in - let cmd = - if nonemptystr n - then Str.global_replace Re.percentp n cmd - else cmd - in - match spawn cmd [] with - | exception exn -> - adderrfmt "spawn" "failed to execute `%s': %s" cmd @@ exntos exn - | _pid -> () - -let getopaque pageno = Hashtbl.find S.pagemap (pageno, !S.gen) - -let pagetranslatepoint l x y = - let dy = y - l.pagedispy in - let y = dy + l.pagey in - let dx = x - l.pagedispx in - let x = dx + l.pagex in - (x, y) - -let onppundermouse g x y d = - let rec f = function - | [] -> d - | l :: rest -> - match getopaque l.pageno with - | exception Not_found -> f rest - | opaque -> - let x0 = l.pagedispx in - let x1 = x0 + l.pagevw in - let y0 = l.pagedispy in - let y1 = y0 + l.pagevh in - if y >= y0 && y <= y1 && x >= x0 && x <= x1 - then - let px, py = pagetranslatepoint l x y in - match g opaque l px py with - | Some res -> res - | None -> f rest - else f rest - in - f !S.layout - -let getunder x y = - let g opaque l px py = - if !S.bzoom - then ( - match Ffi.rectofblock opaque px py with - | Some [|x0;x1;y0;y1|] -> - let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in - let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in - S.rects := [l.pageno, color, rect]; - Glutils.postRedisplay "getunder"; - | _ -> () - ); - let under = Ffi.whatsunder opaque px py in - if under = Unone then None else Some under - in - onppundermouse g x y Unone - -let unproject x y = - let g opaque l x y = - match Ffi.unproject opaque x y with - | Some (x, y) -> Some (Some (opaque, l.pageno, x, y)) - | None -> None - in - onppundermouse g x y None - -let pipesel opaque cmd = - if Ffi.hassel opaque - then - pipef ~closew:false "pipesel" - (fun w -> - Ffi.copysel w opaque; - Glutils.postRedisplay "pipesel" - ) cmd - -let paxunder x y = - let g opaque l px py = - if Ffi.markunder opaque px py conf.paxmark - then - Some (fun () -> - match getopaque l.pageno with - | exception Not_found -> () - | opaque -> pipesel opaque conf.paxcmd - ) - else None - in - Glutils.postRedisplay "paxunder"; - if conf.paxmark = MarkPage - then - List.iter (fun l -> - match getopaque l.pageno with - | exception Not_found -> () - | opaque -> Ffi.clearmark opaque) !S.layout; - S.roamf := onppundermouse g x y (fun () -> impmsg "whoopsie daisy") - -let undertext = function - | Unone -> "none" - | Ulinkuri s -> s - | Utext s -> "font: " ^ s - | Utextannot (opaque, slinkindex) -> - "text annotation: " ^ Ffi.gettextannot opaque slinkindex - | Ufileannot (opaque, slinkindex) -> - "file annotation: " ^ Ffi.getfileannot opaque slinkindex - -let updateunder x y = - match getunder x y with - | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT - | Ulinkuri uri -> - if conf.underinfo then showtext 'u' ("ri: " ^ uri); - Wsi.setcursor Wsi.CURSOR_INFO - | Utext s -> - if conf.underinfo then showtext 'f' ("ont: " ^ s); - Wsi.setcursor Wsi.CURSOR_TEXT - | Utextannot _ -> - if conf.underinfo then showtext 't' "ext annotation"; - Wsi.setcursor Wsi.CURSOR_INFO - | Ufileannot _ -> - if conf.underinfo then showtext 'f' "ile annotation"; - Wsi.setcursor Wsi.CURSOR_INFO - -let showlinktype under = - if conf.underinfo && under != Unone - then showtext ' ' @@ undertext under - -let intentry_with_suffix text key = - let text = - match [@warning "-fragile-match"] key with - | Keys.Ascii ('0'..'9' as c) -> addchar text c - | Keys.Ascii ('k' | 'm' | 'g' | 'K' | 'M' | 'G' as c) -> - addchar text @@ Char.lowercase_ascii c - | _ -> - S.text := "invalid key"; - text - in - TEcont text - -let wcmd cmd fmt = - let b = Buffer.create 16 in - Printf.kbprintf - (fun b -> - Buffer.add_char b cmd; - let b = Buffer.to_bytes b in - Ffi.wcmd !S.ss b @@ Bytes.length b - ) b fmt - -let wcmd1 cmd opaque = - let s = Opaque.to_string opaque in - let l = String.length s in - let b = Bytes.create (l+1) in - Bytes.set b l cmd; - Bytes.blit_string s 0 b 0 l; - Ffi.wcmd !S.ss b @@ l + 1 - -let layoutN ((columns, coverA, coverB), b) x y sw sh = - let rec fold accu n = - if n = Array.length b - then accu - else - let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in - if (vy - y) > sh - && (n = coverA - 1 - || n = !S.pagecount - coverB - || (n - coverA) mod columns = columns - 1) - then accu - else - let accu = - if vy + h > y - then - let pagey = max 0 (y - vy) in - let pagedispy = if pagey > 0 then 0 else vy - y in - let pagedispx, pagex = - let pdx = - if n = coverA - 1 || n = !S.pagecount - coverB - then x + (sw - w) / 2 - else dx + xoff + x - in - if pdx < 0 - then 0, -pdx - else pdx, 0 - in - let pagevw = - let vw = sw - pagedispx in - let pw = w - pagex in - min vw pw - in - let pagevh = min (h - pagey) (sh - pagedispy) in - if pagevw > 0 && pagevh > 0 - then - { pageno = n - ; pagecol = 0 ; pagedimno = pdimno ; pagew = w ; pageh = h - ; pagex ; pagey ; pagevw ; pagevh ; pagedispx ; pagedispy - } :: accu - else accu - else accu - in - fold accu (n+1) - in - if Array.length b = 0 - then [] - else List.rev (fold [] (page_of_y y)) - -let layoutS (columns, b) x y sw sh = - let rec fold accu n = - if n = Array.length b - then accu - else - let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in - if (vy - y) > sh - then accu - else - let accu = - if vy + pageh > y - then - let x = xoff + x in - let pagey = max 0 (y - vy) in - let pagedispy = if pagey > 0 then 0 else vy - y in - let pagedispx, pagex = - if px = 0 - then ( - if x < 0 - then 0, -x - else x, 0 - ) - else ( - let px = px - x in - if px < 0 - then -px, 0 - else 0, px - ) - in - let pagecolw = pagew/columns in - let pagedispx = - if pagecolw < sw - then pagedispx + ((sw - pagecolw) / 2) - else pagedispx - in - let pagevw = - let vw = sw - pagedispx in - let pw = pagew - pagex in - min vw pw - in - let pagevw = min pagevw pagecolw in - let pagevh = min (pageh - pagey) (sh - pagedispy) in - if pagevw > 0 && pagevh > 0 - then - { pageno = n/columns - ; pagedimno = pdimno - ; pagecol = n mod columns - ; pagew ; pageh ; pagex ; pagey ; pagedispx ; pagedispy - ; pagevw ; pagevh - } :: accu - else accu - else accu - in - fold accu (n+1) - in - List.rev (fold [] 0) - -let layout x y sw sh = - if U.nogeomcmds !S.geomcmds - then - match conf.columns with - | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh - | Cmulti c -> layoutN c x y sw sh - | Csplit s -> layoutS s x y sw sh - else [] - -let itertiles l f = - let tilex = l.pagex mod conf.tilew in - let tiley = l.pagey mod conf.tileh in - - let col = l.pagex / conf.tilew in - let row = l.pagey / conf.tileh in - - let rec rowloop row y0 dispy h = - if h != 0 - then - let dh = conf.tileh - y0 in - let dh = min h dh in - let rec colloop col x0 dispx w = - if w != 0 - then - let dw = conf.tilew - x0 in - let dw = min w dw in - f col row dispx dispy x0 y0 dw dh; - colloop (col+1) 0 (dispx+dw) (w-dw) - in - colloop col tilex l.pagedispx l.pagevw; - rowloop (row+1) 0 (dispy+dh) (h-dh) - in - if l.pagevw > 0 && l.pagevh > 0 - then rowloop row tiley l.pagedispy l.pagevh - -let gettileopaque l col row = - let key = l.pageno, !S.gen, conf.colorspace, - conf.angle, l.pagew, l.pageh, col, row in - Hashtbl.find_opt S.tilemap key - -let puttileopaque l col row gen colorspace angle opaque size elapsed = - let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in - Hashtbl.add S.tilemap key (opaque, size, elapsed) - -let drawtiles l color = - let texe e = if conf.invert then GlTex.env (`mode e) in - GlDraw.color color; - Ffi.begintiles (); - let f col row x y tilex tiley w h = - match gettileopaque l col row with - | Some (opaque, _, t) -> - let params = x, y, w, h, tilex, tiley in - texe `blend; - Ffi.drawtile params opaque; - texe `modulate; - if conf.debug - then ( - Ffi.endtiles (); - let s = Printf.sprintf "%d[%d,%d] %f sec" l.pageno col row t in - let w = Ffi.measurestr fstate.fontsize s in - GlDraw.color (0.0, 0.0, 0.0); - Glutils.filledrect - (float (x-2)) - (float (y-2)) - (float (x+2) +. w) - (float (y + fstate.fontsize + 2)); - GlDraw.color color; - Glutils.drawstring fstate.fontsize x (y + fstate.fontsize - 1) s; - Ffi.begintiles (); - ); - - | None -> - Ffi.endtiles (); - let w = let lw = !S.winw - x in min lw w - and h = let lh = !S.winh - y in min lh h in - texe `blend; - let c = if conf.invert then 0.2 else 0.8 in - GlDraw.color (c, c, c); - Glutils.filledrect (float x) (float y) (float (x+w)) (float (y+h)); - texe `modulate; - if w > 128 && h > fstate.fontsize + 10 - then ( - let c = if conf.invert then 1.0 else 0.0 in - GlDraw.color (c, c, c); - let c, r = - if conf.verbose - then (col*conf.tilew, row*conf.tileh) - else col, row - in - Glutils.drawstringf fstate.fontsize x y - "Loading %d [%d,%d]" l.pageno c r; - ); - GlDraw.color color; - Ffi.begintiles (); - in - itertiles l f; - Ffi.endtiles () - -let tilevisible1 l x y = - let ax0 = l.pagex - and ax1 = l.pagex + l.pagevw - and ay0 = l.pagey - and ay1 = l.pagey + l.pagevh in - - let bx0 = x - and by0 = y in - let bx1 = min (bx0 + conf.tilew) l.pagew - and by1 = min (by0 + conf.tileh) l.pageh in - - let rx0 = max ax0 bx0 - and ry0 = max ay0 by0 - and rx1 = min ax1 bx1 - and ry1 = min ay1 by1 in - - let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in - nonemptyintersection - -let tilevisible layout n x y = - let rec findpageinlayout m = function - | l :: rest when l.pageno = n -> - tilevisible1 l x y || ( - match conf.columns with - | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest - | Csplit _ | Csingle _ | Cmulti _ -> false - ) - | _ :: rest -> findpageinlayout 0 rest - | [] -> false - in - findpageinlayout 0 layout - -let tileready l x y = - tilevisible1 l x y && - gettileopaque l (x/conf.tilew) (y/conf.tileh) != None - -let tilepage n p layout = - let rec loop = function - | l :: rest -> - if l.pageno = n - then - let f col row _ _ _ _ _ _ = - if !S.currently = Idle - then - match gettileopaque l col row with - | Some _ -> () - | None -> - let x = col*conf.tilew - and y = row*conf.tileh in - let w = - let w = l.pagew - x in - min w conf.tilew - in - let h = - let h = l.pageh - y in - min h conf.tileh - in - wcmd U.tile "%s %d %d %d %d" (Opaque.to_string p) x y w h; - S.currently := - Tiling ( - l, p, conf.colorspace, conf.angle, - !S.gen, col, row, conf.tilew, conf.tileh - ); - in - itertiles l f; - else loop rest - - | [] -> () - in - if U.nogeomcmds !S.geomcmds - then loop layout - -let preloadlayout x y sw sh = - let y = if y < sh then 0 else y - sh in - let x = min 0 (x + sw) in - let h = sh*3 in - let w = sw*3 in - layout x y w h - -let load pages = - let rec loop pages = - if !S.currently = Idle - then - match pages with - | l :: rest -> - begin match getopaque l.pageno with - | exception Not_found -> - wcmd U.page "%d %d" l.pageno l.pagedimno; - S.currently := Loading (l, !S.gen); - | opaque -> - tilepage l.pageno opaque pages; - loop rest - end - | _ -> () - in - if U.nogeomcmds !S.geomcmds - then loop pages - -let preload pages = - load pages; - if conf.preload && !S.currently = Idle - then load (preloadlayout !S.x !S.y !S.winw !S.winh) - -let alltilesrendered layout = - let exception E in - let rec fold ls = - match ls with - | [] -> true - | l :: rest -> - let foo col row _ _ _ _ _ _ = - match gettileopaque l col row with - | Some _ -> () - | None -> raise E - in - match itertiles l foo with - | () -> fold rest - | exception E -> false - in - fold layout - -let gotoxy x y = - let y = bound y 0 !S.maxy in - let y, layout = - let layout = layout x y !S.winw !S.winh in - Glutils.postRedisplay "gotoxy ready"; - y, layout - in - S.x := x; - S.y := y; - S.layout := layout; - begin match !S.mode with - | LinkNav ln -> - begin match ln with - | Ltexact (pageno, linkno) -> - let rec loop = function - | [] -> - S.lnava := Some (pageno, linkno); - S.mode := LinkNav (Ltgendir 0) - | l :: _ when l.pageno = pageno -> - begin match getopaque pageno with - | exception Not_found -> - S.mode := LinkNav (Ltnotready (pageno, 0)) - | opaque -> - let x0, y0, x1, y1 = Ffi.getlinkrect opaque linkno in - if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw - && y0 >= l.pagey && y1 <= l.pagey + l.pagevh) - then S.mode := LinkNav (Ltgendir 0) - end - | _ :: rest -> loop rest - in - loop layout - | Ltnotready _ | Ltgendir _ -> () - end - | Birdseye _ | Textentry _ | View -> () - end; - begin match !S.mode with - | Birdseye (conf, leftx, pageno, hooverpageno, anchor) -> - if not (U.pagevisible layout pageno) - then ( - match !S.layout with - | [] -> () - | l :: _ -> - S.mode := Birdseye (conf, leftx, l.pageno, hooverpageno, anchor) - ) - | LinkNav lt -> - begin match lt with - | Ltnotready (_, dir) - | Ltgendir dir -> - let linknav = - let rec loop = function - | [] -> lt - | l :: rest -> - match getopaque l.pageno with - | exception Not_found -> Ltnotready (l.pageno, dir) - | opaque -> - let link = - let ld = - if dir = 0 - then LDfirstvisible (l.pagex, l.pagey, dir) - else if dir > 0 then LDfirst else LDlast - in - Ffi.findlink opaque ld - in - match link with - | Lnotfound -> loop rest - | Lfound n -> - showlinktype (Ffi.getlink opaque n); - Ltexact (l.pageno, n) - in - loop !S.layout - in - S.mode := LinkNav linknav - | Ltexact _ -> () - end - | Textentry _ | View -> () - end; - preload layout; - if conf.updatecurs - then ( - let mx, my = !S.mpos in - updateunder mx my; - ) - -let conttiling pageno opaque = - tilepage pageno opaque - (if conf.preload - then preloadlayout !S.x !S.y !S.winw !S.winh - else !S.layout) - -let gotoxy x y = - if not conf.verbose then S.text := E.s; - gotoxy x y - -let getanchory (n, top, dtop) = - let y, h = getpageyh n in - if conf.presentation - then - let ips = calcips h in - y + truncate (top*.float h -. dtop*.float ips) + ips; - else y + truncate (top*.float h -. dtop*.float conf.interpagespace) - -let addnav () = S.nav := { past = getanchor () :: !S.nav.past; future = []; } - -let gotopage n top = - let y, h = getpageyh n in - let y = y + (truncate (top *. float h)) in - gotoxy !S.x y - -let gotopage1 n top = - let y = getpagey n in - let y = y + top in - gotoxy !S.x y - -let invalidate s f = - Glutils.redisplay := false; - S.layout := []; - S.pdims := []; - S.rects := []; - S.rects1 := []; - match !S.geomcmds with - | ps, [] when emptystr ps -> - f (); - S.geomcmds := s, []; - | ps, [] -> S.geomcmds := ps, [s, f]; - | ps, (s', _) :: rest when s' = s -> S.geomcmds := ps, ((s, f) :: rest); - | ps, cmds -> S.geomcmds := ps, ((s, f) :: cmds) - -let flushpages () = - Hashtbl.iter (fun _ opaque -> wcmd1 U.freepage opaque) S.pagemap; - Hashtbl.clear S.pagemap - -let flushtiles () = - if not (Queue.is_empty S.tilelru) - then ( - Queue.iter (fun (k, p, s) -> - wcmd1 U.freetile p; - S.memused := !S.memused - s; - Hashtbl.remove S.tilemap k; - ) S.tilelru; - !S.uioh#infochanged Memused; - Queue.clear S.tilelru; - ); - load !S.layout - -let stateh h = - let h = truncate (float h*.conf.zoom) in - let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in - h - d - -let fillhelp () = - S.help := - let sl = keystostrlist conf in - let rec loop accu = - function | [] -> accu - | s :: rest -> loop ((s, 0, None) :: accu) rest - in Help.makehelp conf.urilauncher - @ (("", 0, None) :: loop [] sl) |> Array.of_list - -let titlify path = - if emptystr path - then path - else - (if emptystr !S.origin then path else !S.origin) - |> Filename.basename |> Ffi.mbtoutf8 - -let settitle title = - conf.title <- title; - if not !S.ignoredoctitlte - then Wsi.settitle @@ title ^ " - llpp" - -let opendoc path mimetype password = - S.path := path; - S.mimetype := mimetype; - S.password := password; - S.gen := !S.gen + 1; - S.docinfo := []; - S.outlines := [||]; - - flushpages (); - Ffi.setaalevel conf.aalevel; - Ffi.setpapercolor conf.papercolor; - Ffi.setdcf conf.dcf; - - settitle @@ titlify path; - wcmd U.dopen "%d %d %d %d %s\000%s\000%s\000%s\000" - (btod conf.usedoccss) conf.rlw conf.rlh conf.rlem - path mimetype password conf.css; - invalidate "reqlayout" - (fun () -> - wcmd U.reqlayout " %d %d %d %s\000" - conf.angle (FMTE.to_int conf.fitmodel) - (stateh !S.winh) !S.nameddest - ); - fillhelp () - -let reload () = - S.anchor := getanchor (); - S.reload := Some (!S.x, !S.y, now ()); - opendoc !S.path !S.mimetype !S.password - -let docolumns columns = - match columns with - | Csingle _ -> - let a = Array.make !S.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in - let rec loop pageno pdimno pdim y ph pdims = - if pageno != !S.pagecount - then - let pdimno, ((_, w, h, xoff) as pdim), pdims = - match pdims with - | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno -> - pdimno+1, pdim, rest - | _ -> - pdimno, pdim, pdims - in - let x = max 0 (((!S.winw - w) / 2) - xoff) in - let y = - y + (if conf.presentation - then (if pageno = 0 then calcips h else calcips ph + calcips h) - else (if pageno = 0 then 0 else conf.interpagespace)) - in - a.(pageno) <- (pdimno, x, y, pdim); - loop (pageno+1) pdimno pdim (y + h) h pdims - in - loop 0 ~-1 (-1,-1,-1,-1) 0 0 !S.pdims; - conf.columns <- Csingle a; - - | Cmulti ((columns, coverA, coverB), _) -> - let a = Array.make !S.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in - let rec loop pageno pdimno pdim x y rowh pdims = - let rec fixrow m = - if m >= pageno - then - let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in - if h < rowh - then a.(m) <- (pdimno, x, y + (rowh - h) / 2, pdim); - fixrow (m+1) - in - if pageno = !S.pagecount - then fixrow (((pageno - 1) / columns) * columns) - else - let pdimno, ((_, w, h, xoff) as pdim), pdims = - match pdims with - | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno -> - pdimno+1, pdim, rest - | _ -> pdimno, pdim, pdims - in - let x, y, rowh' = - if pageno = coverA - 1 || pageno = !S.pagecount - coverB - then ( - let x = (!S.winw - w) / 2 in - let ips = - if conf.presentation then calcips h else conf.interpagespace in - x, y + ips + rowh, h - ) - else ( - if (pageno - coverA) mod columns = 0 - then ( - let x = max 0 (!S.winw - !S.w) / 2 in - let y = - if conf.presentation - then - let ips = calcips h in - y + (if pageno = 0 then 0 else calcips rowh + ips) - else y + (if pageno = 0 then 0 else conf.interpagespace) - in - x, y + rowh, h - ) - else x, y, max rowh h - ) - in - let y = - if pageno > 1 && (pageno - coverA) mod columns = 0 - then ( - let y = - if pageno = columns && conf.presentation - then ( - let ips = calcips rowh in - for i = 0 to pred columns - do - let (pdimno, x, y, pdim) = a.(i) in - a.(i) <- (pdimno, x, y+ips, pdim) - done; - y+ips; - ) - else y - in - fixrow (pageno - columns); - y - ) - else y - in - a.(pageno) <- (pdimno, x, y, pdim); - let x = x + w + xoff*2 + conf.interpagespace in - loop (pageno+1) pdimno pdim x y rowh' pdims - in - loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 !S.pdims; - conf.columns <- Cmulti ((columns, coverA, coverB), a); - - | Csplit (c, _) -> - let a = Array.make (!S.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in - let rec loop pageno pdimno pdim y pdims = - if pageno != !S.pagecount - then - let pdimno, ((_, w, h, _) as pdim), pdims = - match pdims with - | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno -> - pdimno+1, pdim, rest - | _ -> pdimno, pdim, pdims - in - let cw = w / c in - let rec loop1 n x y = - if n = c then y else ( - a.(pageno*c + n) <- (pdimno, x, y, pdim); - loop1 (n+1) (x+cw) (y + h + conf.interpagespace) - ) - in - let y = loop1 0 0 y in - loop (pageno+1) pdimno pdim y pdims - in - loop 0 ~-1 (-1,-1,-1,-1) 0 !S.pdims; - conf.columns <- Csplit (c, a) - -let represent () = - docolumns conf.columns; - S.maxy := calcheight (); - if !S.reprf == noreprf - then ( - match !S.mode with - | Birdseye (_, _, pageno, _, _) -> - let y, h = getpageyh pageno in - let top = (!S.winh - h) / 2 in - gotoxy !S.x (max 0 (y - top)) - | Textentry _ | View | LinkNav _ -> - let y = getanchory !S.anchor in - let y = min y (!S.maxy - !S.winh) in - gotoxy !S.x y; - ) - else ( - !S.reprf (); - S.reprf := noreprf; - ) - -let reshape ?(firsttime=false) w h = - GlDraw.viewport ~x:0 ~y:0 ~w ~h; - if not firsttime && U.nogeomcmds !S.geomcmds - then S.anchor := getanchor (); - - S.winw := w; - let w = truncate (float w *. conf.zoom) in - let w = max w 2 in - S.winh := h; - setfontsize fstate.fontsize; - GlMat.mode `modelview; - GlMat.load_identity (); - - GlMat.mode `projection; - GlMat.load_identity (); - GlMat.rotate ~x:1.0 ~angle:180.0 (); - GlMat.translate ~x:~-.1.0 ~y:~-.1.0 (); - GlMat.scale3 (2.0 /. float !S.winw, 2.0 /. float !S.winh, 1.0); - - let relx = - if conf.zoom <= 1.0 - then 0.0 - else float !S.x /. float !S.w - in - invalidate "geometry" - (fun () -> - S.w := w; - if not firsttime - then S.x := truncate (relx *. float w); - let w = - match conf.columns with - | Csingle _ -> w - | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c - | Csplit (c, _) -> w * c - in - wcmd U.geometry "%d %d %d" w (stateh h) (FMTE.to_int conf.fitmodel) - ) - -let gctilesnotinlayout layout = - let len = Queue.length S.tilelru in - let rec loop qpos = - if !S.memused > conf.memlimit - then ( - if qpos < len - then - let (k, p, s) as lruitem = Queue.pop S.tilelru in - let n, gen, colorspace, angle, pagew, pageh, col, row = k in - let (_, pw, ph, _) = getpagedim n in - if gen = !S.gen - && colorspace = conf.colorspace - && angle = conf.angle - && pagew = pw - && pageh = ph - && ( - let x = col*conf.tilew and y = row*conf.tileh in - tilevisible layout n x y - ) - then Queue.push lruitem S.tilelru - else ( - wcmd1 U.freetile p; - S.memused := !S.memused - s; - !S.uioh#infochanged Memused; - Hashtbl.remove S.tilemap k; - ); - loop (qpos+1) - ) - in - loop 0 - -let onpagerect pageno f = - let b = - match conf.columns with - | Cmulti (_, b) -> b - | Csingle b -> b - | Csplit (_, b) -> b - in - if pageno >= 0 && pageno < Array.length b - then - let (_, _, _, (_, w, h, _)) = b.(pageno) in - f w h - -let gotopagexy1 pageno x y = - let _,w1,h1,leftx = getpagedim pageno in - let top = y /. (float h1) in - let left = x /. (float w1) in - let py, w, h = getpageywh pageno in - let wh = !S.winh in - let x = left *. (float w) in - let x = leftx + !S.x + truncate x in - let sx = - if x < 0 || x >= !S.winw - then !S.x - x - else !S.x - in - let pdy = truncate (top *. float h) in - let y' = py + pdy in - let dy = y' - !S.y in - let sy = - if x != !S.x || not (dy > 0 && dy < wh) - then ( - if conf.presentation - then - if abs (py - y') > wh - then y' - else py - else y'; - ) - else !S.y - in - if !S.x != sx || !S.y != sy - then gotoxy sx sy - else gotoxy !S.x !S.y - -let gotopagexy pageno x y = - match !S.mode with - | Birdseye _ -> gotopage pageno 0.0 - | Textentry _ | View | LinkNav _ -> gotopagexy1 pageno x y - -let getpassword () = - let passcmd = getenvdef "LLPP_ASKPASS" conf.passcmd in - if emptystr passcmd - then (adderrmsg "askpass" "ask password program not set"; E.s) - else getcmdoutput (adderrfmt passcmd "failed to obrain password: %s") passcmd - -let pgoto opaque pageno x y = - let pdimno = getpdimno pageno in - let x, y = Ffi.project opaque pageno pdimno x y in - gotopagexy pageno x y - -let act cmds = - (* dolog "%S" cmds; *) - let spl = splitatchar cmds ' ' in - let scan s fmt f = - try Scanf.sscanf s fmt f - with exn -> - dolog "error scanning %S: %s" cmds @@ exntos exn; - exit 1 - in - let addoutline outline = - match !S.currently with - | Outlining outlines -> S.currently := Outlining (outline :: outlines) - | Idle -> S.currently := Outlining [outline] - | Loading _ | Tiling _ -> - dolog "Invalid outlining state"; - logcurrently !S.currently - in - match spl with - | "clear", "" -> - S.pdims := []; - !S.uioh#infochanged Pdim; - - | "clearrects", "" -> - S.rects := !S.rects1; - Glutils.postRedisplay "clearrects"; - - | "continue", args -> - let n = scan args "%u" (fun n -> n) in - S.pagecount := n; - begin match !S.currently with - | Outlining l -> - S.currently := Idle; - S.outlines := Array.of_list (List.rev l) - | Idle | Loading _ | Tiling _ -> () - end; - - let cur, cmds = !S.geomcmds in - if emptystr cur then error "empty geomcmd"; - - begin match List.rev cmds with - | [] -> - S.geomcmds := E.s, []; - represent (); - | (s, f) :: rest -> - f (); - S.geomcmds := s, List.rev rest; - end; - Glutils.postRedisplay "continue"; - - | "vmsg", args -> - if conf.verbose then showtext ' ' args - - | "emsg", args -> - if not !S.redirstderr - then Format.eprintf "%s@." args - else ( - Buffer.add_string S.errmsgs args; - Buffer.add_char S.errmsgs '\n'; - if not !S.newerrmsgs - then ( - S.newerrmsgs := true; - Glutils.postRedisplay "error message"; - ) - ); - - | "progress", args -> - let progress, text = - scan args "%f %n" - (fun f pos -> f, String.sub args pos (String.length args - pos)) - in - S.text := text; - S.progress := progress; - Glutils.postRedisplay "progress" - - | "match", args -> - let pageno, n, x0, y0, x1, y1, x2, y2, x3, y3 = - scan args "%u %d %f %f %f %f %f %f %f %f" - (fun p n x0 y0 x1 y1 x2 y2 x3 y3 -> - (p, n, x0, y0, x1, y1, x2, y2, x3, y3)) - in - if n = 0 - then ( - let y = (getpagey pageno) + truncate y0 in - let x = - if (!S.x < - truncate x0) || (!S.x > !S.winw - truncate x1) - then !S.winw/2 - truncate (x0 /. 2. +. x1 /. 2.) - else !S.x - in - addnav (); - gotoxy x y; - ); - let color = (0.0, 0.0, (if n = 0 then 1.0 else 0.5), 0.5) in - S.rects1 := - (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: !S.rects1 - - | "page", args -> - let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in - let pageopaque = Opaque.of_string pageopaques in - begin match !S.currently with - | Loading (l, gen) -> - vlog "page %d took %f sec" l.pageno t; - Hashtbl.replace S.pagemap (l.pageno, gen) pageopaque; - let preloadedpages = - if conf.preload - then preloadlayout !S.x !S.y !S.winw !S.winh - else !S.layout - in - let evict () = - let set = List.fold_left (fun s l -> IntSet.add l.pageno s) - IntSet.empty preloadedpages - in - let evictedpages = - Hashtbl.fold (fun ((pageno, _) as key) opaque accu -> - if not (IntSet.mem pageno set) - then ( - wcmd1 U.freepage opaque; - key :: accu - ) - else accu - ) S.pagemap [] - in - List.iter (Hashtbl.remove S.pagemap) evictedpages; - in - evict (); - S.currently := Idle; - if gen = !S.gen - then ( - tilepage l.pageno pageopaque !S.layout; - load !S.layout; - load preloadedpages; - let visible = U.pagevisible !S.layout l.pageno in - if visible - then ( - match !S.mode with - | LinkNav (Ltnotready (pageno, dir)) -> - if pageno = l.pageno - then ( - let link = - let ld = - if dir = 0 - then LDfirstvisible (l.pagex, l.pagey, dir) - else if dir > 0 then LDfirst else LDlast - in - Ffi.findlink pageopaque ld - in - match link with - | Lnotfound -> () - | Lfound n -> - showlinktype (Ffi.getlink pageopaque n); - S.mode := LinkNav (Ltexact (l.pageno, n)) - ) - | LinkNav (Ltgendir _) - | LinkNav (Ltexact _) - | View - | Birdseye _ - | Textentry _ -> () - ); - - if visible && alltilesrendered !S.layout - then Glutils.postRedisplay "page"; - ) - - | Idle | Tiling _ | Outlining _ -> - dolog "Inconsistent loading state"; - logcurrently !S.currently; - exit 1 - end - - | "tile" , args -> - (* - C part is notifying us that it has finished rendering a tile - valid = the tile fits current config (i.e. the settings with which - the tile has been rendered match current ones) - - if the tile is not valid free it and issue loading/rendering commands - for the current layout - - evict all the tiles that aren't part of preloadlayout - if tile is visible post redisplay - continue tiling - *) - let (x, y, opaques, size, t) = - scan args "%u %u %s %u %f" (fun x y p size t -> (x, y, p, size, t)) - in - let opaque = Opaque.of_string opaques in - begin match !S.currently with - | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) -> - vlog "tile %d [%d,%d] took %f sec" l.pageno col row t; - let layout = - if conf.preload && alltilesrendered !S.layout - then preloadlayout !S.x !S.y !S.winw !S.winh - else !S.layout - in - if tilew != conf.tilew || tileh != conf.tileh - then ( - wcmd1 U.freetile opaque; - S.currently := Idle; - load layout; - ) - else ( - puttileopaque l col row gen cs angle opaque size t; - S.memused := !S.memused + size; - !S.uioh#infochanged Memused; - gctilesnotinlayout !S.layout; - Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row), - opaque, size) S.tilelru; - - S.currently := Idle; - let visible = tilevisible layout l.pageno x y in - let cont = gen = !S.gen && conf.colorspace = cs - && conf.angle = angle && visible - in - - if cont - then conttiling l.pageno pageopaque; - preload layout; - if cont - then Glutils.postRedisplay "tile nothrottle"; - ) - - | Idle | Loading _ | Outlining _ -> - dolog "Inconsistent tiling state"; - logcurrently !S.currently; - exit 1 - end - - | "pdim", args -> - let (n, w, h, _) as pdim = - scan args "%u %d %d %d" (fun n x w h -> n, w, h, x) - in - let pdim = - match conf.fitmodel with - | FitWidth -> pdim - | FitPage | FitProportional -> - match conf.columns with - | Csplit _ -> (n, w, h, 0) - | Csingle _ | Cmulti _ -> pdim - in - S.pdims := pdim :: !S.pdims; - !S.uioh#infochanged Pdim - - | "o", args -> - let (l, n, t, h, pos) = - scan args "%u %u %d %u %n" (fun l n t h pos -> l, n, t, h, pos) - in - let s = String.sub args pos (String.length args - pos) in - addoutline (s, l, Oanchor (n, float t /. float h, 0.0)) - - | "ou", args -> - let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in - let s = String.sub args pos len in - let pos2 = pos + len + 1 in - let uri = String.sub args pos2 (String.length args - pos2) in - addoutline (s, l, Ouri uri) - - | "on", args -> - let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in - let s = String.sub args pos (String.length args - pos) in - addoutline (s, l, Onone) - - | "a", args -> - let (n, l, t) = scan args "%u %d %d" (fun n l t -> n, l, t) in - S.reprf := (fun () -> gotopagexy n (float l) (float t)) - - | "info", args -> - let s = - match splitatchar args '\t' with - | "Title", "" -> - settitle @@ Filename.basename !S.path; - E.s - | "Title", v -> - settitle v; - args - | _, "" -> E.s - | c, v -> - if let len = String.length c in - len > 6 && ((String.sub c (len-4) 4) = "date") - then ( - if String.length v >= 7 && v.[0] = 'D' && v.[1] = ':' - then - let b = Buffer.create 10 in - Printf.bprintf b "%s\t" c; - let sub p l c = - try - Buffer.add_substring b v p l; - Buffer.add_char b c; - with exn -> Buffer.add_string b @@ exntos exn - in - sub 2 4 '/'; - sub 6 2 '/'; - sub 8 2 ' '; - sub 10 2 ':'; - sub 12 2 ':'; - sub 14 2 ' '; - Printf.bprintf b "[%s]" v; - Buffer.contents b - else args - ) - else args - in - if nonemptystr s then S.docinfo := (1, s) :: !S.docinfo - - | "infoend", "" -> - S.docinfo := List.rev !S.docinfo; - !S.uioh#infochanged Docinfo - - | "pass", args -> - if args = "fail" - then adderrmsg "pass" "Wrong password"; - let password = getpassword () in - if emptystr password - then error "document is password protected" - else opendoc !S.path !S.mimetype password - - | _ -> error "unknown cmd `%S'" cmds - -let onhist cb = - let rc = cb.rc in - let action = function - | HCprev -> cbget cb ~-1 - | HCnext -> cbget cb 1 - | HCfirst -> cbget cb ~-(cb.rc) - | HClast -> cbget cb (cb.len - 1 - cb.rc) - and cancel () = cb.rc <- rc - in (action, cancel) - -let search pattern forward = - match conf.columns with - | Csplit _ -> - impmsg "searching while in split columns mode is not implemented" - | Csingle _ | Cmulti _ -> - if nonemptystr pattern - then - let pn, py = - match !S.layout with - | [] -> 0, 0 - | l :: _ -> l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh) - in - S.rects1 := []; - wcmd U.search "%d %d %d %d,%s\000" - (btod conf.icase) pn py (btod forward) pattern - -let intentry text key = - let text = - if emptystr text && key = Keys.Ascii '-' - then addchar text '-' - else - match [@warning "-fragile-match"] key with - | Keys.Ascii ('0'..'9' as c) -> addchar text c - | _ -> - S.text := "invalid key"; - text - in - TEcont text - -let linknact f s = - if nonemptystr s - then - let rec loop off = function - | [] -> () - | l :: rest -> - match getopaque l.pageno with - | exception Not_found -> loop off rest - | opaque -> - let n = Ffi.getlinkn opaque conf.hcs s off in - if n <= 0 - then loop n rest - else Ffi.getlink opaque (n-1) |> f - in - loop 0 !S.layout - -let linknentry text = function [@warning "-fragile-match"] - | Keys.Ascii c -> - let text = addchar text c in - linknact (fun under -> S.text := undertext under) text; - TEcont text - | key -> - settextfmt "invalid key %s" @@ Keys.to_string key; - TEcont text - -let textentry text key = match [@warning "-fragile-match"] key with - | Keys.Ascii c -> TEcont (addchar text c) - | Keys.Code c -> TEcont (text ^ Ffi.toutf8 c) - | _ -> TEcont text - -let reqlayout angle fitmodel = - if U.nogeomcmds !S.geomcmds - then S.anchor := getanchor (); - conf.angle <- angle mod 360; - if conf.angle != 0 - then ( - match !S.mode with - | LinkNav _ -> S.mode := View - | Birdseye _ | Textentry _ | View -> () - ); - conf.fitmodel <- fitmodel; - invalidate "reqlayout" - (fun () -> wcmd U.reqlayout "%d %d %d" - conf.angle (FMTE.to_int conf.fitmodel) (stateh !S.winh)) - -let settrim trimmargins trimfuzz = - if U.nogeomcmds !S.geomcmds - then S.anchor := getanchor (); - conf.trimmargins <- trimmargins; - conf.trimfuzz <- trimfuzz; - let x0, y0, x1, y1 = trimfuzz in - invalidate "settrim" - (fun () -> wcmd U.settrim "%d %d %d %d %d" - (btod conf.trimmargins) x0 y0 x1 y1); - flushpages () - -let setzoom zoom = - let zoom = max 0.0001 zoom in - if zoom <> conf.zoom - then ( - S.prevzoom := (conf.zoom, !S.x); - conf.zoom <- zoom; - reshape !S.winw !S.winh; - settextfmt "zoom is now %-5.2f" (zoom *. 100.0); - ) - -let pivotzoom ?(vw=min !S.w !S.winw) - ?(vh=min (!S.maxy - !S.y) !S.winh) - ?(x=vw/2) ?(y=vh/2) zoom = - let w = float !S.w /. zoom in - let hw = w /. 2.0 in - let ratio = float vh /. float vw in - let hh = hw *. ratio in - let x0 = float x -. hw +. !S.xf and y0 = float y -. hh +. !S.yf in - let xf, xr = modf x0 and yf, yr = modf y0 in - S.xf := xf; - S.yf := yf; - gotoxy (!S.x - truncate xr) (!S.y + truncate yr); - setzoom zoom - -let pivotzoom ?vw ?vh ?x ?y zoom = - if U.nogeomcmds !S.geomcmds - then - if zoom > 1.0 - then pivotzoom ?vw ?vh ?x ?y zoom - else setzoom zoom - -let setcolumns mode columns coverA coverB = - S.prevcolumns := Some (conf.columns, conf.zoom); - if columns < 0 - then ( - if isbirdseye mode - then impmsg "split mode doesn't work in bird's eye" - else ( - conf.columns <- Csplit (-columns, E.a); - S.x := 0; - conf.zoom <- 1.0; - ); - ) - else ( - if columns < 2 - then ( - conf.columns <- Csingle E.a; - S.x := 0; - setzoom 1.0; - ) - else ( - conf.columns <- Cmulti ((columns, coverA, coverB), E.a); - conf.zoom <- 1.0; - ); - ); - reshape !S.winw !S.winh - -let resetmstate () = - S.mstate := Mnone; - Wsi.setcursor Wsi.CURSOR_INHERIT - -let enterbirdseye () = - let zoom = float conf.thumbw /. float !S.winw in - let birdseyepageno = - let cy = !S.winh / 2 in - let fold = function - | [] -> 0 - | l :: rest -> - let rec fold best = function - | [] -> best.pageno - | l :: rest -> - let d = cy - (l.pagedispy + l.pagevh/2) - and dbest = cy - (best.pagedispy + best.pagevh/2) in - if abs d < abs dbest - then fold l rest - else best.pageno - in fold l rest - in - fold !S.layout - in - S.mode := - Birdseye ( - { conf with zoom = conf.zoom }, - !S.x, birdseyepageno, -1, getanchor () - ); - resetmstate (); - conf.zoom <- zoom; - conf.presentation <- false; - conf.interpagespace <- 10; - conf.hlinks <- false; - conf.fitmodel <- FitPage; - S.x := 0; - conf.columns <- ( - match conf.beyecolumns with - | Some c -> - conf.zoom <- 1.0; - Cmulti ((c, 0, 0), E.a) - | None -> Csingle E.a - ); - if conf.verbose - then settextfmt "birds eye on (zoom %3.1f%%)" (100.0*.zoom); - reshape !S.winw !S.winh - -let leavebirdseye (c, leftx, pageno, _, anchor) goback = - S.mode := View; - conf.zoom <- c.zoom; - conf.presentation <- c.presentation; - conf.interpagespace <- c.interpagespace; - conf.hlinks <- c.hlinks; - conf.fitmodel <- c.fitmodel; - conf.beyecolumns <- ( - match conf.columns with - | Cmulti ((c, _, _), _) -> Some c - | Csingle _ -> None - | Csplit _ -> error "leaving bird's eye split mode" - ); - conf.columns <- ( - match c.columns with - | Cmulti (c, _) -> Cmulti (c, E.a) - | Csingle _ -> Csingle E.a - | Csplit (c, _) -> Csplit (c, E.a) - ); - if conf.verbose - then settextfmt "bird's eye off (zoom %3.1f%%)" (100.0*.conf.zoom); - reshape !S.winw !S.winh; - S.anchor := if goback then anchor else (pageno, 0.0, 1.0); - S.x := leftx - -let togglebirdseye () = - match !S.mode with - | Birdseye vals -> leavebirdseye vals true - | View -> enterbirdseye () - | Textentry _ | LinkNav _ -> () - -let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) = - let pageno = max 0 (pageno - incr) in - let rec loop = function - | [] -> gotopage1 pageno 0 - | l :: _ when l.pageno = pageno -> - if l.pagedispy >= 0 && l.pagey = 0 - then Glutils.postRedisplay "upbirdseye" - else gotopage1 pageno 0 - | _ :: rest -> loop rest - in - loop !S.layout; - S.text := E.s; - S.mode := Birdseye (conf, leftx, pageno, hooverpageno, anchor) - -let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) = - let pageno = min (!S.pagecount - 1) (pageno + incr) in - S.mode := Birdseye (conf, leftx, pageno, hooverpageno, anchor); - let rec loop = function - | [] -> - let y, h = getpageyh pageno in - let dy = (y - !S.y) - (!S.winh - h - conf.interpagespace) in - gotoxy !S.x (U.add_to_y_and_clamp dy) - | l :: _ when l.pageno = pageno -> - if l.pagevh != l.pageh - then - let inc = l.pageh - l.pagevh + conf.interpagespace in - gotoxy !S.x (U.add_to_y_and_clamp inc) - else Glutils.postRedisplay "downbirdseye" - | _ :: rest -> loop rest - in - loop !S.layout; - S.text := E.s - -let optentry mode _ key = - match [@warning "-fragile-match"] key with - | Keys.Ascii 'C' -> - let ondone s = - try - let n, a, b = multicolumns_of_string s in - setcolumns mode n a b; - with exn -> settextfmt "bad columns `%s': %s" s @@ exntos exn - in - TEswitch ("columns: ", E.s, None, textentry, ondone, true) - - | Keys.Ascii 'Z' -> - let ondone s = - try - let zoom = float (int_of_string s) /. 100.0 in - pivotzoom zoom - with exn -> settextfmt "bad integer `%s': %s" s @@ exntos exn - in - TEswitch ("zoom: ", E.s, None, intentry, ondone, true) - - | Keys.Ascii 'i' -> - conf.icase <- not conf.icase; - TEdone ("case insensitive search " ^ (onoffs conf.icase)) - - | Keys.Ascii 'v' -> - conf.verbose <- not conf.verbose; - TEdone ("verbose " ^ (onoffs conf.verbose)) - - | Keys.Ascii 'd' -> - conf.debug <- not conf.debug; - TEdone ("debug " ^ (onoffs conf.debug)) - - | Keys.Ascii 'f' -> - conf.underinfo <- not conf.underinfo; - TEdone ("underinfo " ^ onoffs conf.underinfo) - - | Keys.Ascii 'T' -> - settrim (not conf.trimmargins) conf.trimfuzz; - TEdone ("trim margins " ^ onoffs conf.trimmargins) - - | Keys.Ascii 'I' -> - conf.invert <- not conf.invert; - TEdone ("invert colors " ^ onoffs conf.invert) - - | Keys.Ascii 'x' -> - let ondone s = - cbput !S.hists.sel s; - conf.selcmd <- s; - in - TEswitch ("selection command: ", E.s, Some (onhist !S.hists.sel), - textentry, ondone, true) - - | Keys.Ascii 'M' -> - if conf.pax == None - then conf.pax <- Some 0.0 - else conf.pax <- None; - TEdone ("PAX " ^ onoffs (conf.pax != None)) - - | (Keys.Ascii c) -> - settextfmt "bad option %d `%c'" (Char.code c) c; - TEstop - - | _ -> TEcont !S.text - -class outlinelistview ~zebra ~source = - let settext autonarrow s = - S.text := - if autonarrow - then - let ss = source#statestr in - if emptystr ss then "[" ^ s ^ "]" else "{" ^ ss ^ "} [" ^ s ^ "]" - else s - in - object (self) - inherit listview - ~zebra - ~helpmode:false - ~source:(source :> lvsource) - ~trusted:false - ~modehash:(findkeyhash conf "outline") - as super - - val m_autonarrow = false - - method! key key mask = - let maxrows = - if emptystr !S.text - then fstate.maxrows - else fstate.maxrows - 2 - in - let calcfirst first active = - if active > first - then - let rows = active - first in - if rows > maxrows then active - maxrows else first - else active - in - let navigate incr = - let active = m_active + incr in - let active = bound active 0 (source#getitemcount - 1) in - let first = calcfirst m_first active in - Glutils.postRedisplay "outline navigate"; - coe {< m_active = active; m_first = first >} - in - let navscroll first = - let active = - let dist = m_active - first in - if dist < 0 - then first - else ( - if dist < maxrows - then m_active - else first + maxrows - ) - in - Glutils.postRedisplay "outline navscroll"; - coe {< m_first = first; m_active = active >} - in - let ctrl = Wsi.withctrl mask in - let open Keys in - match Wsi.ks2kt key with - | Ascii 'a' when ctrl -> - let text = - if m_autonarrow - then ( - source#denarrow; - E.s - ) - else ( - let pattern = source#renarrow in - if nonemptystr m_qsearch - then (source#narrow m_qsearch; m_qsearch) - else pattern - ) - in - settext (not m_autonarrow) text; - Glutils.postRedisplay "toggle auto narrowing"; - coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >} - | Ascii '/' when emptystr m_qsearch && not m_autonarrow -> - settext true E.s; - Glutils.postRedisplay "toggle auto narrowing"; - coe {< m_first = 0; m_active = 0; m_autonarrow = true >} - | Ascii 'n' when ctrl -> - source#narrow m_qsearch; - if not m_autonarrow - then source#add_narrow_pattern m_qsearch; - Glutils.postRedisplay "outline ctrl-n"; - coe {< m_first = 0; m_active = 0 >} - | Ascii 'S' when ctrl -> - let active = source#calcactive (getanchor ()) in - let first = firstof m_first active in - Glutils.postRedisplay "outline ctrl-s"; - coe {< m_first = first; m_active = active >} - | Ascii 'u' when ctrl -> - Glutils.postRedisplay "outline ctrl-u"; - if m_autonarrow && nonemptystr m_qsearch - then ( - ignore (source#renarrow); - settext m_autonarrow E.s; - coe {< m_first = 0; m_active = 0; m_qsearch = E.s >} - ) - else ( - source#del_narrow_pattern; - let pattern = source#renarrow in - let text = - if emptystr pattern then E.s else "Narrowed to " ^ pattern - in - settext m_autonarrow text; - coe {< m_first = 0; m_active = 0; m_qsearch = E.s >} - ) - | Ascii 'l' when ctrl -> - let first = max 0 (m_active - (fstate.maxrows / 2)) in - Glutils.postRedisplay "outline ctrl-l"; - coe {< m_first = first >} - - | Ascii '\t' when m_autonarrow -> - if nonemptystr m_qsearch - then ( - Glutils.postRedisplay "outline list view tab"; - source#add_narrow_pattern m_qsearch; - settext true E.s; - coe {< m_qsearch = E.s >} - ) - else coe self - | Escape when m_autonarrow -> - if nonemptystr m_qsearch - then source#add_narrow_pattern m_qsearch; - super#key key mask - | Enter when m_autonarrow -> - if nonemptystr m_qsearch - then source#add_narrow_pattern m_qsearch; - super#key key mask - | (Ascii _ | Code _) when m_autonarrow -> - let pattern = m_qsearch ^ Ffi.toutf8 key in - Glutils.postRedisplay "outlinelistview autonarrow add"; - source#narrow pattern; - settext true pattern; - coe {< m_first = 0; m_active = 0; m_qsearch = pattern >} - | Backspace when m_autonarrow -> - if emptystr m_qsearch - then coe self - else - let pattern = withoutlastutf8 m_qsearch in - Glutils.postRedisplay "outlinelistview autonarrow backspace"; - ignore (source#renarrow); - source#narrow pattern; - settext true pattern; - coe {< m_first = 0; m_active = 0; m_qsearch = pattern >} - | Up when ctrl -> navscroll (max 0 (m_first-1)) - | Down when ctrl -> navscroll (min (source#getitemcount-1) (m_first+1)) - | Up -> navigate ~-1 - | Down -> navigate 1 - | Prior -> navigate ~-(fstate.maxrows) - | Next -> navigate fstate.maxrows - | Right -> - (if ctrl - then ( - Glutils.postRedisplay "outline ctrl right"; - {< m_pan = m_pan + 1 >} - ) - else ( - if Wsi.withshift mask - then self#nextcurlevel 1 - else self#updownlevel 1 - )) |> coe - | Left -> - (if ctrl - then ( - Glutils.postRedisplay "outline ctrl left"; - {< m_pan = m_pan - 1 >} - ) - else ( - if Wsi.withshift mask - then self#nextcurlevel ~-1 - else self#updownlevel ~-1 - )) |> coe - | Home -> - Glutils.postRedisplay "outline home"; - coe {< m_first = 0; m_active = 0 >} - | End -> - let active = source#getitemcount - 1 in - let first = max 0 (active - fstate.maxrows) in - Glutils.postRedisplay "outline end"; - coe {< m_active = active; m_first = first >} - | Delete|Escape|Insert|Enter|Ascii _|Code _|Ctrl _|Backspace|Fn _ -> - super#key key mask - end - -let genhistoutlines () = - Config.gethist () - |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) -> - compare c2.lastvisit c1.lastvisit) - |> List.map (fun ((path, c, _, _, _, origin) as hist) -> - let path = if nonemptystr origin then origin else path in - let base = Ffi.mbtoutf8 @@ Filename.basename path in - (base ^ "\000" ^ c.title, 1, Ohistory hist) - ) - -let gotohist (path, c, bookmarks, x, anchor, origin) = - Config.save leavebirdseye; - setconf conf c; - let x0, y0, x1, y1 = conf.trimfuzz in - wcmd U.trimset "%d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1; - Wsi.reshape c.cwinw c.cwinh; - opendoc path !S.mimetype origin; - conf.zoom <- nan; - setzoom c.zoom; - S.anchor := anchor; - S.bookmarks := bookmarks; - S.origin := origin; - S.x := x - -let describe_layout layout = - let d = - match layout with - | [] -> "Page 0" - | l :: [] -> Printf.sprintf "Page %d" (l.pageno+1) - | l :: rest -> - let rangestr a b = - if a.pageno = b.pageno then Printf.sprintf "%d" (a.pageno+1) - else Printf.sprintf "%d%s%d" (a.pageno+1) - (if a.pageno+1 = b.pageno then ", " else Utf8syms.ellipsis) - (b.pageno+1) - in - let rec fold s la lb = function - | [] -> Printf.sprintf "%s %s" s (rangestr la lb) - | l :: rest when l.pageno = succ lb.pageno -> fold s la l rest - | l :: rest -> fold (s ^ " " ^ rangestr la lb ^ ",") l l rest - in - fold "Pages" l l rest - in - let percent = - let maxy = U.maxy () in - if maxy <= 0 - then 100. - else 100. *. (float !S.y /. float maxy) - in - Printf.sprintf "%s of %d [%.2f%%]" d !S.pagecount percent - -let setpresentationmode v = - let n = page_of_y !S.y in - S.anchor := (n, 0.0, 1.0); - conf.presentation <- v; - if conf.fitmodel = FitPage - then reqlayout conf.angle conf.fitmodel; - represent () - -let infomenu = - let modehash = lazy (findkeyhash conf "info") in (fun source -> - S.text := E.s; - new listview ~zebra:false ~helpmode:false ~source - ~trusted:true ~modehash:(Lazy.force_val modehash) |> coe) - -let enterinfomode = - let btos b = if b then Utf8syms.radical else E.s in - let showextended = ref false in - let showcolors = ref false in - let showcommands = ref false in - let showrefl = ref false in - let leave mode _ = S.mode := mode in - let src = object - val mutable m_l = [] - val mutable m_a = E.a - val mutable m_prev_uioh = nouioh - val mutable m_prev_mode = View - - inherit lvsourcebase - - method reset prev_mode prev_uioh = - m_a <- Array.of_list (List.rev m_l); - m_l <- []; - m_prev_mode <- prev_mode; - m_prev_uioh <- prev_uioh; - - method int name get set = - m_l <- - (name, `int get, 1, - Some (fun u -> - let ondone s = - try set (int_of_string s) - with exn -> settextfmt "bad integer `%s': %s" s @@ exntos exn - in - S.text := E.s; - let te = (name ^ ": ", E.s, None, intentry, ondone, true) in - S.mode := Textentry (te, leave m_prev_mode); - u - )) :: m_l - - method int_with_suffix name get set = - m_l <- - (name, `intws get, 1, - Some (fun u -> - let ondone s = - try set (int_of_string_with_suffix s) - with exn -> settextfmt "bad integer `%s': %s" s @@ exntos exn - in - S.text := E.s; - let te = (name ^ ": ", E.s, None, intentry_with_suffix, - ondone, true) in - S.mode := Textentry (te, leave m_prev_mode); - u - )) :: m_l - - method bool ?(offset=1) ?(btos=btos) name get set = - m_l <- (name, `bool (btos, get), offset, - Some (fun u -> set (not (get ())); u)) :: m_l - - method color name get set = - m_l <- - (name, `color get, 1, - Some (fun u -> - let invalid = (nan, nan, nan) in - let ondone s = - let c = - try color_of_string s - with exn -> settextfmt "bad color `%s': %s" s @@ exntos exn; - invalid - in - if c <> invalid - then set c; - in - let te = (name ^ ": ", E.s, None, textentry, ondone, true) in - S.text := color_to_string (get ()); - S.mode := Textentry (te, leave m_prev_mode); - u - )) :: m_l - - method string name get set = - m_l <- - (name, `string get, 1, - Some (fun u -> - let ondone s = set s in - let te = (String.trim name ^ ": ", E.s, None, - textentry, ondone, true) in - S.mode := Textentry (te, leave m_prev_mode); - u - )) :: m_l - - method colorspace name get set = - m_l <- - (name, `string get, 1, - Some (fun _ -> - let source = object - inherit lvsourcebase - - initializer - m_active <- CSTE.to_int conf.colorspace; - m_first <- 0; - - method getitemcount = - Array.length CSTE.names - method getitem n = - (CSTE.names.(n), 0) - method exit ~uioh ~cancel ~active ~first ~pan = - ignore (uioh, first, pan); - if not cancel then set active; - None - method hasaction _ = true - end - in - infomenu source - )) :: m_l - - method paxmark name get set = - m_l <- - (name, `string get, 1, - Some (fun _ -> - let source = object - inherit lvsourcebase - - initializer - m_active <- MTE.to_int conf.paxmark; - m_first <- 0; - - method getitemcount = Array.length MTE.names - method getitem n = (MTE.names.(n), 0) - method exit ~uioh ~cancel ~active ~first ~pan = - ignore (uioh, first, pan); - if not cancel then set active; - None - method hasaction _ = true - end - in - infomenu source - )) :: m_l - - method fitmodel name get set = - m_l <- - (name, `string get, 1, - Some (fun _ -> - let source = object - inherit lvsourcebase - - initializer - m_active <- FMTE.to_int conf.fitmodel; - m_first <- 0; - - method getitemcount = Array.length FMTE.names - method getitem n = (FMTE.names.(n), 0) - method exit ~uioh ~cancel ~active ~first ~pan = - ignore (uioh, first, pan); - if not cancel then set active; - None - method hasaction _ = true - end - in - infomenu source - )) :: m_l - - method caption s offset = - m_l <- (s, `empty, offset, None) :: m_l - - method caption2 s f offset = - m_l <- (s, `string f, offset, None) :: m_l - - method getitemcount = Array.length m_a - - method getitem n = - let tostr = function - | `int f -> string_of_int (f ()) - | `intws f -> string_with_suffix_of_int (f ()) - | `string f -> f () - | `color f -> color_to_string (f ()) - | `bool (btos, f) -> btos (f ()) - | `empty -> E.s - in - let name, t, offset, _ = m_a.(n) in - ((let s = tostr t in - if nonemptystr s - then Printf.sprintf "%s\t%s" name s - else name), - offset) - - method exit ~uioh ~cancel ~active ~first ~pan = - let uiohopt = - if not cancel - then ( - let uioh = - match m_a.(active) with - | _, _, _, Some f -> f uioh - | _, _, _, None -> uioh - in - Some uioh - ) - else None - in - m_active <- active; - m_first <- first; - m_pan <- pan; - uiohopt - - method hasaction n = - match m_a.(n) with - | _, _, _, Some _ -> true - | _, _, _, None -> false - - initializer m_active <- 1 - end - in - let rec fillsrc prevmode prevuioh = - let sep () = src#caption E.s 0 in - let bad v exn = settextfmt "bad color `%s': %s" v @@ exntos exn in - let colorp name get set = - src#string name - (fun () -> color_to_string (get ())) - (fun v -> - try set @@ color_of_string v - with exn -> bad v exn - ) - in - let rgba name get set = - src#string name - (fun () -> get () |> rgba_to_string) - (fun v -> - try set @@ rgba_of_string v - with exn -> bad v exn - ) - in - let oldmode = !S.mode in - let birdseye = isbirdseye !S.mode in - - src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0; - - src#bool "presentation mode" - (fun () -> conf.presentation) - (fun v -> setpresentationmode v); - - src#bool "ignore case in searches" - (fun () -> conf.icase) - (fun v -> conf.icase <- v); - - src#bool "preload" - (fun () -> conf.preload) - (fun v -> conf.preload <- v); - - src#bool "highlight links" - (fun () -> conf.hlinks) - (fun v -> conf.hlinks <- v); - - src#bool "under info" - (fun () -> conf.underinfo) - (fun v -> conf.underinfo <- v); - - src#fitmodel "fit model" - (fun () -> FMTE.to_string conf.fitmodel) - (fun v -> reqlayout conf.angle (FMTE.of_int v)); - - src#bool "trim margins" - (fun () -> conf.trimmargins) - (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh); - - sep (); - src#int "inter-page space" - (fun () -> conf.interpagespace) - (fun n -> - conf.interpagespace <- n; - docolumns conf.columns; - let pageno, py = - match !S.layout with - | [] -> 0, 0 - | l :: _ -> l.pageno, l.pagey - in - S.maxy :=- calcheight (); - gotoxy !S.x (py + getpagey pageno) - ); - - src#int "page bias" - (fun () -> conf.pagebias) - (fun v -> conf.pagebias <- v); - - src#int "scroll step" - (fun () -> conf.scrollstep) - (fun n -> conf.scrollstep <- n); - - src#int "horizontal scroll step" - (fun () -> conf.hscrollstep) - (fun v -> conf.hscrollstep <- v); - - src#int "auto scroll step" - (fun () -> - match !S.autoscroll with - | Some step -> step - | _ -> conf.autoscrollstep) - (fun n -> - let n = boundastep !S.winh n in - if !S.autoscroll <> None - then S.autoscroll := Some n; - conf.autoscrollstep <- n); - - src#int "zoom" - (fun () -> truncate (conf.zoom *. 100.)) - (fun v -> pivotzoom ((float v) /. 100.)); - - src#int "rotation" - (fun () -> conf.angle) - (fun v -> reqlayout v conf.fitmodel); - - src#int "scroll bar width" - (fun () -> conf.scrollbw) - (fun v -> - conf.scrollbw <- v; - reshape !S.winw !S.winh; - ); - - src#int "scroll handle height" - (fun () -> conf.scrollh) - (fun v -> conf.scrollh <- v;); - - src#int "thumbnail width" - (fun () -> conf.thumbw) - (fun v -> - conf.thumbw <- min 4096 v; - match oldmode with - | Birdseye beye -> - leavebirdseye beye false; - enterbirdseye () - | Textentry _ | View | LinkNav _ -> () - ); - - let mode = !S.mode in - src#string "columns" - (fun () -> - match conf.columns with - | Csingle _ -> "1" - | Cmulti (multi, _) -> multicolumns_to_string multi - | Csplit (count, _) -> "-" ^ string_of_int count - ) - (fun v -> - let n, a, b = multicolumns_of_string v in - setcolumns mode n a b); - - sep (); - src#caption "Pixmap cache" 0; - src#int_with_suffix "size (advisory)" - (fun () -> conf.memlimit) - (fun v -> conf.memlimit <- v); - - src#caption2 "used" - (fun () -> - Printf.sprintf "%s bytes, %d tiles" - (string_with_suffix_of_int !S.memused) - (Hashtbl.length S.tilemap)) 1; - - sep (); - src#caption "Layout" 0; - src#caption2 "Dimension" - (fun () -> Printf.sprintf "%dx%d (virtual %dx%d)" - !S.winw !S.winh - !S.w !S.maxy) - 1; - if conf.debug - then src#caption2 "Position" (fun () -> - Printf.sprintf "%dx%d" !S.x !S.y - ) 1 - else src#caption2 "Position" (fun () -> describe_layout !S.layout) 1; - - sep (); - let btos b = Utf8syms.(if b then lguillemet else rguillemet) in - src#bool ~offset:0 ~btos "Extended parameters" - (fun () -> !showextended) - (fun v -> showextended := v; fillsrc prevmode prevuioh); - if !showextended - then ( - src#bool "update cursor" - (fun () -> conf.updatecurs) - (fun v -> conf.updatecurs <- v); - src#bool "scroll-bar on the left" - (fun () -> conf.leftscroll) - (fun v -> conf.leftscroll <- v); - src#bool "verbose" - (fun () -> conf.verbose) - (fun v -> conf.verbose <- v); - src#bool "invert colors" - (fun () -> conf.invert) - (fun v -> conf.invert <- v); - src#bool "max fit" - (fun () -> conf.maxhfit) - (fun v -> conf.maxhfit <- v); - src#bool "pax mode" - (fun () -> conf.pax != None) - (fun v -> - if v - then conf.pax <- Some (now ()) - else conf.pax <- None); - src#string "tile size" - (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh) - (fun v -> - try - let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in - conf.tilew <- max 64 w; - conf.tileh <- max 64 h; - flushtiles (); - with exn -> settextfmt "bad tile size `%s': %s" v @@ exntos exn); - src#int "texture count" - (fun () -> conf.texcount) - (fun v -> - if Ffi.realloctexts v - then conf.texcount <- v - else impmsg "failed to set texture count please retry later"); - src#int "slice height" - (fun () -> conf.sliceheight) - (fun v -> - conf.sliceheight <- v; - wcmd U.sliceh "%d" conf.sliceheight); - src#int "anti-aliasing level" - (fun () -> conf.aalevel) - (fun v -> - conf.aalevel <- bound v 0 8; - S.anchor := getanchor (); - opendoc !S.path !S.mimetype !S.password); - src#string "page scroll scaling factor" - (fun () -> string_of_float conf.pgscale) - (fun v -> - try conf.pgscale <- float_of_string v - with exn -> - S.text := - Printf.sprintf "bad page scroll scaling factor `%s': %s" v - @@ exntos exn); - src#int "ui font size" - (fun () -> fstate.fontsize) - (fun v -> setfontsize (bound v 5 100)); - src#int "hint font size" - (fun () -> conf.hfsize) - (fun v -> conf.hfsize <- bound v 5 100); - src#string "hint chars" - (fun () -> conf.hcs) - (fun v -> - try - validatehcs v; - conf.hcs <- v - with exn -> - S.text := - Printf.sprintf "invalid hint chars %S: %s" v (exntos exn)); - src#string "trim fuzz" - (fun () -> irect_to_string conf.trimfuzz) - (fun v -> - try - conf.trimfuzz <- irect_of_string v; - if conf.trimmargins - then settrim true conf.trimfuzz; - with exn -> settextfmt "bad irect `%s': %s" v @@ exntos exn); - src#bool ~btos "external commands" - (fun () -> !showcommands) - (fun v -> showcommands := v; fillsrc prevmode prevuioh); - if !showcommands - then ( - src#string " uri launcher" - (fun () -> conf.urilauncher) - (fun v -> conf.urilauncher <- v); - src#string " path launcher" - (fun () -> conf.pathlauncher) - (fun v -> conf.pathlauncher <- v); - src#string " selection" - (fun () -> conf.selcmd) - (fun v -> conf.selcmd <- v); - src#string " synctex" - (fun () -> conf.stcmd) - (fun v -> conf.stcmd <- v); - src#string " pax" - (fun () -> conf.paxcmd) - (fun v -> conf.paxcmd <- v); - src#string " ask password" - (fun () -> conf.passcmd) - (fun v -> conf.passcmd <- v); - src#string " save path" - (fun () -> conf.savecmd) - (fun v -> conf.savecmd <- v); - ); - src#colorspace "color space" - (fun () -> CSTE.to_string conf.colorspace) - (fun v -> - conf.colorspace <- CSTE.of_int v; - wcmd U.cs "%d" v; - load !S.layout); - src#paxmark "pax mark method" - (fun () -> MTE.to_string conf.paxmark) - (fun v -> conf.paxmark <- MTE.of_int v); - src#bool "mouse wheel scrolls pages" - (fun () -> conf.wheelbypage) - (fun v -> conf.wheelbypage <- v); - src#bool "open remote links in a new instance" - (fun () -> conf.riani) - (fun v -> conf.riani <- v); - src#bool "edit annotations inline" - (fun () -> conf.annotinline) - (fun v -> conf.annotinline <- v); - src#bool "coarse positioning in presentation mode" - (fun () -> conf.coarseprespos) - (fun v -> conf.coarseprespos <- v); - src#bool "use document CSS" - (fun () -> conf.usedoccss) - (fun v -> - conf.usedoccss <- v; - S.anchor := getanchor (); - opendoc !S.path !S.mimetype !S.password); - src#bool ~btos "colors" - (fun () -> !showcolors) - (fun v -> showcolors := v; fillsrc prevmode prevuioh); - if !showcolors - then ( - colorp " background" - (fun () -> conf.bgcolor) - (fun v -> conf.bgcolor <- v); - rgba " paper" - (fun () -> conf.papercolor) - (fun v -> - conf.papercolor <- v; - Ffi.setpapercolor conf.papercolor; - flushtiles (); - ); - rgba " scrollbar" - (fun () -> conf.sbarcolor) - (fun v -> conf.sbarcolor <- v); - rgba " scrollbar handle" - (fun () -> conf.sbarhndlcolor) - (fun v -> conf.sbarhndlcolor <- v); - rgba " texture" - (fun () -> conf.texturecolor) - (fun v -> - GlTex.env (`color v); - conf.texturecolor <- v; - ); - src#string " scale" - (fun () -> string_of_float conf.colorscale) - (fun v -> conf.colorscale <- bound (float_of_string v) 0.0 1.0); - ); - src#bool ~btos "reflowable layout" - (fun () -> !showrefl) - (fun v -> showrefl := v; fillsrc prevmode prevuioh); - if !showrefl - then ( - src#int " width" - (fun () -> conf.rlw) - (fun v -> conf.rlw <- v; reload ()); - src#int " height" - (fun () -> conf.rlh) - (fun v -> conf.rlh <- v; reload ()); - src#int " em" - (fun () -> conf.rlem) - (fun v -> conf.rlem <- v; reload ()); - ); - ); - - sep (); - src#caption "Document" 0; - List.iter (fun (_, s) -> src#caption s 1) !S.docinfo; - src#caption2 "Pages" (fun () -> string_of_int !S.pagecount) 1; - src#caption2 "Dimensions" - (fun () -> string_of_int (List.length !S.pdims)) 1; - if nonemptystr conf.css - then src#caption2 "CSS" (fun () -> conf.css) 1; - if conf.trimmargins - then ( - sep (); - src#caption "Trimmed margins" 0; - src#caption2 "Dimensions" - (fun () -> string_of_int (List.length !S.pdims)) 1; - ); - - sep (); - src#caption "OpenGL" 0; - src#caption ("Vendor\t" ^ GlMisc.get_string `vendor) 1; - src#caption ("Renderer\t" ^ GlMisc.get_string `renderer) 1; - - sep (); - src#caption "Location" 0; - if nonemptystr !S.origin - then src#caption ("Origin\t" ^ Ffi.mbtoutf8 !S.origin) 1; - src#caption ("Path\t" ^ Ffi.mbtoutf8 !S.path) 1; - if nonemptystr conf.dcf - then src#caption ("DCF\t" ^ Ffi.mbtoutf8 conf.dcf) 1; - - src#reset prevmode prevuioh; - in - fun () -> ( - S.text := E.s; - resetmstate (); - let prevmode = !S.mode - and prevuioh = !S.uioh in - fillsrc prevmode prevuioh; - let source = (src :> lvsource) in - let modehash = findkeyhash conf "info" in - object (self) - inherit listview ~zebra:false ~helpmode:false - ~source ~trusted:true ~modehash as super - val mutable m_prevmemused = 0 - method! infochanged = function - | Memused -> - if m_prevmemused != !S.memused - then ( - m_prevmemused <- !S.memused; - Glutils.postRedisplay "memusedchanged"; - ) - | Pdim -> Glutils.postRedisplay "pdimchanged" - | Docinfo -> fillsrc prevmode prevuioh - method! key key mask = - if not (Wsi.withctrl mask) - then - match [@warning "-fragile-match"] Wsi.ks2kt key with - | Keys.Left -> coe (self#updownlevel ~-1) - | Keys.Right -> coe (self#updownlevel 1) - | _ -> super#key key mask - else super#key key mask - end |> setuioh; - Glutils.postRedisplay "info"; - ) - -let enterhelpmode = - let source = object - inherit lvsourcebase - method getitemcount = Array.length !S.help - method getitem n = - let s, l, _ = !S.help.(n) in - (s, l) - - method exit ~uioh ~cancel ~active ~first ~pan = - let optuioh = - if not cancel - then ( - match !S.help.(active) with - | _, _, Some f -> Some (f uioh) - | _, _, None -> Some uioh - ) - else None - in - m_active <- active; - m_first <- first; - m_pan <- pan; - optuioh - - method hasaction n = - match !S.help.(n) with - | _, _, Some _ -> true - | _, _, None -> false - - initializer m_active <- -1 - end - in fun () -> - let modehash = findkeyhash conf "help" in - resetmstate (); - new listview ~zebra:false ~helpmode:true - ~source ~trusted:true ~modehash |> setuioh; - Glutils.postRedisplay "help" - -let entermsgsmode = - let msgsource = object - inherit lvsourcebase - val mutable m_items = E.a - - method getitemcount = 1 + Array.length m_items - - method getitem n = - if n = 0 - then "[Clear]", 0 - else m_items.(n-1), 0 - - method exit ~uioh ~cancel ~active ~first ~pan = - ignore uioh; - if not cancel - then ( - if active = 0 - then Buffer.clear S.errmsgs; - ); - m_active <- active; - m_first <- first; - m_pan <- pan; - None - - method hasaction n = - n = 0 - - method reset = - S.newerrmsgs := false; - let l = Str.split Re.crlf (Buffer.contents S.errmsgs) in - m_items <- Array.of_list l - - initializer m_active <- 0 - end - in - fun () -> - S.text := E.s; - resetmstate (); - msgsource#reset; - let source = (msgsource :> lvsource) in - let modehash = findkeyhash conf "listview" in - object - inherit listview ~zebra:false ~helpmode:false - ~source ~trusted:false ~modehash as super - method! display = - if !S.newerrmsgs - then msgsource#reset; - super#display - end |> setuioh; - Glutils.postRedisplay "msgs" - -let getusertext s = - let editor = getenvdef "EDITOR" E.s in - if emptystr editor - then E.s - else - let tmppath = Filename.temp_file "llpp" "note" in - if nonemptystr s - then ( - let oc = open_out tmppath in - output_string oc s; - close_out oc; - ); - let execstr = editor ^ " " ^ tmppath in - let eret r = Printf.ksprintf (fun s -> adderrmsg "gtut:eret" s; r) in - let s = - match spawn execstr [] with - | exception exn -> eret E.s "spawn(%S) failed: %s" execstr @@ exntos exn - | pid -> - match Unix.waitpid [] pid with - | exception exn -> eret E.s "waitpid(%d) failed: %s" pid @@ exntos exn - | (_pid, status) -> - match status with - | Unix.WEXITED 0 -> filecontents tmppath - | Unix.WEXITED n -> - eret E.s "editor process(%s) exited abnormally: %d" execstr n - | Unix.WSIGNALED n -> - eret E.s "editor process(%s) was killed by signal %d" execstr n - | Unix.WSTOPPED n -> - eret E.s "editor(%s) process was stopped by signal %d" execstr n - in - match Unix.unlink tmppath with - | exception exn -> eret s "failed to ulink %S: %s" tmppath @@ exntos exn - | () -> s - -let enterannotmode opaque slinkindex = - let msgsource = object - inherit lvsourcebase - val mutable m_text = E.s - val mutable m_items = E.a - - method getitemcount = Array.length m_items - - method getitem n = - let label, _func = m_items.(n) in - label, 0 - - method exit ~uioh ~cancel ~active ~first ~pan = - ignore (uioh, first, pan); - if not cancel - then ( - let _label, func = m_items.(active) in - func () - ); - None - - method hasaction n = nonemptystr @@ fst m_items.(n) - - method reset s = - let rec split accu b i = - let p = b+i in - if p = String.length s - then (String.sub s b (p-b), fun () -> ()) :: accu - else - if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n' - then - let ss = if i = 0 then E.s else String.sub s b i in - split ((ss, fun () -> ())::accu) (p+1) 0 - else split accu b (i+1) - in - let cleanup () = - wcmd1 U.freepage opaque; - let keys = - Hashtbl.fold (fun key opaque' accu -> - if opaque' = opaque' - then key :: accu else accu) S.pagemap [] - in - List.iter (Hashtbl.remove S.pagemap) keys; - flushtiles (); - gotoxy !S.x !S.y - in - let dele () = - Ffi.delannot opaque slinkindex; - cleanup (); - in - let edit inline () = - let update s = - if emptystr s - then dele () - else ( - Ffi.modannot opaque slinkindex s; - cleanup (); - ) - in - if inline - then - let mode = !S.mode in - let te = ("annotation: ", m_text, None, textentry, update, true) in - S.mode := Textentry (te, fun _ -> S.mode := mode); - S.text := E.s; - enttext (); - else getusertext m_text |> update - in - m_text <- s; - m_items <- - ( "[Copy]", fun () -> selstring conf.selcmd m_text) - :: ("[Delete]", dele) - :: ("[Edit]", edit conf.annotinline) - :: (E.s, fun () -> ()) - :: split [] 0 0 |> List.rev |> Array.of_list - - initializer m_active <- 0 - end - in - S.text := E.s; - let s = Ffi.gettextannot opaque slinkindex in - resetmstate (); - msgsource#reset s; - let source = (msgsource :> lvsource) in - let modehash = findkeyhash conf "listview" in - object inherit listview ~zebra:false - ~helpmode:false ~source ~trusted:false ~modehash - end |> setuioh; - Glutils.postRedisplay "enterannotmode" - -let gotoremote spec = - let filename, dest = splitatchar spec '#' in - let getpath filename = - let path = - if nonemptystr filename - then - if Filename.is_relative filename - then - let dir = Filename.dirname !S.path in - let dir = - if Filename.is_implicit dir - then Filename.concat (Sys.getcwd ()) dir - else dir - in - Filename.concat dir filename - else filename - else E.s - in - if Sys.file_exists path - then path - else E.s - in - let path = getpath filename in - if emptystr path - then adderrfmt "gotoremote/getpath" "failed getpath for %S\n" filename - else - let dospawn lcmd = - if conf.riani - then - let cmd = Lazy.force_val lcmd in - match spawn cmd with - | exception exn -> dolog "failed to execute `%s': %s" cmd @@ exntos exn - | _pid -> () - else - let anchor = getanchor () in - let ranchor = !S.path, !S.mimetype, !S.password, anchor, !S.origin in - S.origin := E.s; - S.ranchors := ranchor :: !S.ranchors; - opendoc path E.s E.s; - in - if substratis spec 0 "page=" - then - match Scanf.sscanf spec "page=%d" (fun n -> n) with - | exception exn -> - adderrfmt "error parsing remote destination" "%s %s" spec @@ exntos exn - | pageno -> - S.anchor := (pageno, 0.0, 0.0); - dospawn @@ lazy (Printf.sprintf "%s -page %d %S" - !S.selfexec pageno path); - else ( - S.nameddest := dest; - dospawn @@ lazy (!S.selfexec ^ " " ^ path ^ " -dest " ^ dest) - ) - -let gotounder = function - | Ulinkuri s when Ffi.isexternallink s -> - if substratis s 0 "file://" - then gotoremote @@ String.sub s 7 (String.length s - 7) - else Help.gotouri conf.urilauncher s - | Ulinkuri s -> - let pageno, x, y = Ffi.uritolocation s in - addnav (); - gotopagexy pageno x y - | Utext _ | Unone -> () - | Utextannot (opaque, slinkindex) -> enterannotmode opaque slinkindex - | Ufileannot (opaque, slinkindex) -> - if emptystr conf.savecmd - then adderrmsg "savepath-command is empty" - "don't know where to save attachment" - else - let filename = Ffi.getfileannot opaque slinkindex in - let savecmd = Str.global_replace Re.percents filename conf.savecmd in - let path = - getcmdoutput - (adderrfmt savecmd - "failed to obtain path to the saved attachment: %s") savecmd - in - Ffi.savefileannot opaque slinkindex path - -let gotooutline (_, _, kind) = - match kind with - | Onone -> () - | Oanchor ((pageno, y, _) as anchor) -> - addnav (); - gotoxy !S.x @@ - getanchory (if conf.presentation then (pageno, y, 1.0) else anchor) - | Ouri uri -> gotounder (Ulinkuri uri) - | Olaunch cmd -> error "gotounder (Ulaunch %S)" cmd - | Oremote (remote, pageno) -> - error "gotounder (Uremote (%S,%d) )" remote pageno - | Ohistory hist -> gotohist hist - | Oremotedest (path, dest) -> - error "gotounder (Uremotedest (%S, %S))" path dest - -class outlinesoucebase fetchoutlines = object (self) - inherit lvsourcebase - val mutable m_items = E.a - val mutable m_minfo = E.a - val mutable m_orig_items = E.a - val mutable m_orig_minfo = E.a - val mutable m_narrow_patterns = [] - val mutable m_gen = -1 - - method getitemcount = Array.length m_items - - method getitem n = - let s, n, _ = m_items.(n) in - (s, n+0) - - method exit ~(uioh:uioh) ~cancel ~active ~(first:int) ~pan : uioh option = - ignore (uioh, first); - let items, minfo = - if m_narrow_patterns = [] - then m_orig_items, m_orig_minfo - else m_items, m_minfo - in - m_pan <- pan; - if not cancel - then ( - m_items <- items; - m_minfo <- minfo; - gotooutline m_items.(active); - ) - else ( - m_items <- items; - m_minfo <- minfo; - ); - None - - method hasaction (_:int) = true - - method greetmsg = - if Array.length m_items != Array.length m_orig_items - then - let s = - match m_narrow_patterns with - | one :: [] -> one - | many -> String.concat Utf8syms.ellipsis (List.rev many) - in - "Narrowed to " ^ s ^ " (ctrl-u to restore)" - else E.s - - method statestr = - match m_narrow_patterns with - | [] -> E.s - | one :: [] -> one - | head :: _ -> Utf8syms.ellipsis ^ head - - method narrow pattern = - match Str.regexp_case_fold pattern with - | exception _ -> () - | re -> - let rec loop accu minfo n = - if n = -1 - then ( - m_items <- Array.of_list accu; - m_minfo <- Array.of_list minfo; - ) - else - let (s, _, _) as o = m_items.(n) in - let accu, minfo = - match Str.search_forward re s 0 with - | exception Not_found -> accu, minfo - | first -> o :: accu, (first, Str.match_end ()) :: minfo - in - loop accu minfo (n-1) - in - loop [] [] (Array.length m_items - 1) - - method! getminfo = m_minfo - - method denarrow = - m_orig_items <- fetchoutlines (); - m_minfo <- m_orig_minfo; - m_items <- m_orig_items - - method add_narrow_pattern pattern = - m_narrow_patterns <- pattern :: m_narrow_patterns - - method del_narrow_pattern = - match m_narrow_patterns with - | _ :: rest -> m_narrow_patterns <- rest - | [] -> () - - method renarrow = - self#denarrow; - match m_narrow_patterns with - | pattern :: [] -> self#narrow pattern; pattern - | list -> - List.fold_left (fun accu pattern -> - self#narrow pattern; - pattern ^ Utf8syms.ellipsis ^ accu) E.s list - - method calcactive (_:anchor) = 0 - - method reset anchor items = - if !S.gen != m_gen - then ( - m_orig_items <- items; - m_items <- items; - m_narrow_patterns <- []; - m_minfo <- E.a; - m_orig_minfo <- E.a; - m_gen <- !S.gen; - ) - else ( - if items != m_orig_items - then ( - m_orig_items <- items; - if m_narrow_patterns == [] - then m_items <- items; - ) - ); - let active = self#calcactive anchor in - m_active <- active; - m_first <- firstof m_first active -end - -let outlinesource fetchoutlines = object - inherit outlinesoucebase fetchoutlines - method! calcactive anchor = - let rely = getanchory anchor in - let rec loop n best bestd = - if n = Array.length m_items - then best - else - let _, _, kind = m_items.(n) in - match kind with - | Oanchor anchor -> - let orely = getanchory anchor in - let d = abs (orely - rely) in - if d < bestd - then loop (n+1) n d - else loop (n+1) best bestd - | Onone | Oremote _ | Olaunch _ - | Oremotedest _ | Ouri _ | Ohistory _ -> - loop (n+1) best bestd - in - loop 0 ~-1 max_int - end - -let enteroutlinemode, enterbookmarkmode, enterhistmode = - let fetchoutlines sourcetype () = - match sourcetype with - | `bookmarks -> Array.of_list !S.bookmarks - | `outlines -> !S.outlines - | `history -> genhistoutlines () |> Array.of_list - in - let so = outlinesource (fetchoutlines `outlines) in - let sb = outlinesource (fetchoutlines `bookmarks) in - let sh = outlinesource (fetchoutlines `history) in - let mkselector sourcetype source = - (fun emptymsg -> - let outlines = fetchoutlines sourcetype () in - if Array.length outlines = 0 - then showtext ' ' emptymsg - else ( - resetmstate (); - Wsi.setcursor Wsi.CURSOR_INHERIT; - let anchor = getanchor () in - source#reset anchor outlines; - S.text := source#greetmsg; - new outlinelistview ~zebra:(sourcetype=`history) ~source |> setuioh; - Glutils.postRedisplay "enter selector"; - ) - ) - in - let mkenter src errmsg s = fun () -> mkselector src s errmsg in - ( mkenter `outlines "document has no outline" so - , mkenter `bookmarks "document has no bookmarks (yet)" sb - , mkenter `history "history is empty" sh ) - -let addbookmark title a = - let b = List.filter (fun (title', _, _) -> title <> title') !S.bookmarks in - S.bookmarks := (title, 0, Oanchor a) :: b - -let quickbookmark ?title () = - match !S.layout with - | [] -> () - | l :: _ -> - let title = - match title with - | None -> - Unix.( - let tm = localtime (now ()) in - Printf.sprintf - "Quick (page %d) (bookmarked on %02d/%02d/%d at %02d:%02d)" - (l.pageno+1) - tm.tm_mday (tm.tm_mon+1) (tm.tm_year+1900) tm.tm_hour tm.tm_min - ) - | Some title -> title - in - addbookmark title (getanchor1 l) - -let setautoscrollspeed step goingdown = - let incr = max 1 ((abs step) / 2) in - let incr = if goingdown then incr else -incr in - let astep = boundastep !S.winh (step + incr) in - S.autoscroll := Some astep - -let canpan () = - match conf.columns with - | Csplit _ -> true - | Csingle _ | Cmulti _ -> !S.x != 0 || conf.zoom > 1.0 - -let existsinrow pageno (columns, coverA, coverB) p = - let last = ((pageno - coverA) mod columns) + columns in - let rec any = function - | [] -> false - | l :: rest -> - if l.pageno = coverA - 1 || l.pageno = !S.pagecount - coverB - then p l - else ( - if not (p l) - then (if l.pageno = last then false else any rest) - else true - ) - in - any !S.layout - -let nextpage () = - match !S.layout with - | [] -> - let pageno = page_of_y !S.y in - gotoxy !S.x (getpagey (pageno+1)) - | l :: rest -> - match conf.columns with - | Csingle _ -> - if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh - then - let y = U.add_to_y_and_clamp (U.pgscale !S.winh) in - gotoxy !S.x y - else - let pageno = min (l.pageno+1) (!S.pagecount-1) in - gotoxy !S.x (getpagey pageno) - | Cmulti ((c, _, _) as cl, _) -> - if conf.presentation - && (existsinrow l.pageno cl - (fun l -> l.pageh > l.pagey + l.pagevh)) - then - let y = U.add_to_y_and_clamp (U.pgscale !S.winh) in - gotoxy !S.x y - else - let pageno = min (l.pageno+c) (!S.pagecount-1) in - gotoxy !S.x (getpagey pageno) - | Csplit (n, _) -> - if l.pageno < !S.pagecount - 1 || l.pagecol < n - 1 - then - let pagey, pageh = getpageyh l.pageno in - let pagey = pagey + pageh * l.pagecol in - let ips = if l.pagecol = 0 then 0 else conf.interpagespace in - gotoxy !S.x (pagey + pageh + ips) - -let prevpage () = - match !S.layout with - | [] -> - let pageno = page_of_y !S.y in - gotoxy !S.x (getpagey (pageno-1)) - | l :: _ -> - match conf.columns with - | Csingle _ -> - if conf.presentation && l.pagey != 0 - then gotoxy !S.x (U.add_to_y_and_clamp (U.pgscale ~-(!S.winh))) - else - let pageno = max 0 (l.pageno-1) in - gotoxy !S.x (getpagey pageno) - | Cmulti ((c, _, coverB) as cl, _) -> - if conf.presentation && - (existsinrow l.pageno cl (fun l -> l.pagey != 0)) - then gotoxy !S.x (U.add_to_y_and_clamp (U.pgscale ~-(!S.winh))) - else - let decr = - if l.pageno = !S.pagecount - coverB - then 1 - else c - in - let pageno = max 0 (l.pageno-decr) in - gotoxy !S.x (getpagey pageno) - | Csplit (n, _) -> - let y = - if l.pagecol = 0 - then - if l.pageno = 0 - then l.pagey - else - let pageno = max 0 (l.pageno-1) in - let pagey, pageh = getpageyh pageno in - pagey + (n-1)*pageh - else - let pagey, pageh = getpageyh l.pageno in - pagey + pageh * (l.pagecol-1) - conf.interpagespace - in - gotoxy !S.x y - -let save () = - if emptystr conf.savecmd - then adderrmsg "savepath-command is empty" - "don't know where to save modified document" - else - let savecmd = Str.global_replace Re.percents !S.path conf.savecmd in - let path = - getcmdoutput - (adderrfmt savecmd "failed to obtain path to the saved copy: %s") - savecmd - in - if nonemptystr path - then - let tmp = path ^ ".tmp" in - Ffi.savedoc tmp; - Unix.rename tmp path - -let viewkeyboard key mask = - let enttext te = - let mode = !S.mode in - S.mode := Textentry (te, fun _ -> S.mode := mode); - S.text := E.s; - enttext (); - Glutils.postRedisplay "view:enttext" - and histback () = - match !S.nav.past with - | [] -> () - | prev :: prest -> - S.nav := { past = prest ; future = getanchor () :: !S.nav.future; }; - gotoxy !S.x (getanchory prev) - in - let ctrl = Wsi.withctrl mask in - let open Keys in - match Wsi.ks2kt key with - | Ascii 'Q' -> exit 0 - | Ascii 'z' -> - let yloc f = - match List.rev !S.rects with - | [] -> () - | (pageno, _, (_, y0, _, y1, _, y2, _, y3)) :: _ -> - f pageno (y0, y1, y2, y3) - and fsel f (y0, y1, y2, y3) = f y0 y1 |> f y2 |> f y3 |> truncate in - let ondone msg = S.text := msg - and zmod _ _ k = - match [@warning "-fragile-match"] k with - | Keys.Ascii 'z' -> - let f pageno ys = - let miny = fsel min ys in - let hh = (fsel max ys - miny)/2 in - gotopage1 pageno (miny + hh - !S.winh/2) - in - yloc f; - TEdone "center" - | Keys.Ascii 't' -> - let f pageno ys = gotopage1 pageno @@ fsel min ys in - yloc f; - TEdone "top" - | Keys.Ascii 'b' -> - let f pageno ys = gotopage1 pageno (fsel max ys - !S.winh) in - yloc f; - TEdone "bottom" - | _ -> TEstop - in - enttext (": ", E.s, None, zmod !S.mode, ondone, true) - | Ascii 'W' -> - if Ffi.hasunsavedchanges () - then save () - | Insert -> - if conf.angle mod 360 = 0 && not (isbirdseye !S.mode) - then ( - S.mode := ( - match !S.lnava with - | None -> LinkNav (Ltgendir 0) - | Some pn -> LinkNav (Ltexact pn) - ); - gotoxy !S.x !S.y; - ) - else impmsg "keyboard link navigation does not work under rotation" - | Escape | Ascii 'q' -> - begin match !S.mstate with - | Mzoomrect _ -> - resetmstate (); - Glutils.postRedisplay "kill rect"; - | Msel _ - | Mpan _ - | Mscrolly | Mscrollx - | Mzoom _ - | Mnone -> - begin match !S.mode with - | LinkNav ln -> - begin match ln with - | Ltexact pl -> S.lnava := Some pl - | Ltgendir _ | Ltnotready _ -> S.lnava := None - end; - S.mode := View; - Glutils.postRedisplay "esc leave linknav" - | Birdseye _ | Textentry _ | View -> - match !S.ranchors with - | [] -> raise Quit - | (path, mimetype, password, anchor, origin) :: rest -> - S.ranchors := rest; - S.anchor := anchor; - S.origin := origin; - S.nameddest := E.s; - opendoc path mimetype password - end; - end; - | Ascii 'o' -> enteroutlinemode () - | Ascii 'u' -> - S.rects := []; - S.text := E.s; - Hashtbl.iter (fun _ opaque -> Ffi.clearmark opaque) S.pagemap; - Glutils.postRedisplay "dehighlight"; - | Ascii (('/' | '?') as c) -> - let ondone isforw s = - cbput !S.hists.pat s; - S.searchpattern := s; - search s isforw - in - enttext (String.make 1 c, E.s, Some (onhist !S.hists.pat), - textentry, ondone (c = '/'), true) - | Ascii '+' | Ascii '=' when ctrl -> - let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in - pivotzoom (conf.zoom +. incr) - | Ascii '+' -> - let ondone s = - let n = - try int_of_string s with exn -> - S.text := Printf.sprintf "bad integer `%s': %s" s @@ exntos exn; - max_int - in - if n != max_int - then ( - conf.pagebias <- n; - S.text := "page bias is now " ^ string_of_int n; - ) - in - enttext ("page bias: ", E.s, None, intentry, ondone, true) - | Ascii '-' when ctrl -> - let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in - pivotzoom (max 0.01 (conf.zoom -. decr)) - | Ascii '-' -> - let ondone msg = S.text := msg in - enttext ("option: ", E.s, None, - optentry !S.mode, ondone, true) - | Ascii '0' when ctrl -> - if conf.zoom = 1.0 - then gotoxy 0 !S.y - else setzoom 1.0 - | Ascii ('1'|'2' as c) when ctrl && conf.fitmodel != FitPage -> - let cols = - match conf.columns with - | Csingle _ | Cmulti _ -> 1 - | Csplit (n, _) -> n - in - let h = !S.winh - - conf.interpagespace lsl (if conf.presentation then 1 else 0) - in - let zoom = Ffi.zoomforh !S.winw h 0 cols in - if zoom > 0.0 && (c = '2' || zoom < 1.0) - then setzoom zoom - | Ascii '3' when ctrl -> - let fm = - match conf.fitmodel with - | FitWidth -> FitProportional - | FitProportional -> FitPage - | FitPage -> FitWidth - in - S.text := "fit model: " ^ FMTE.to_string fm; - reqlayout conf.angle fm - | Ascii '4' when ctrl -> - let zoom = Ffi.getmaxw () /. float !S.winw in - if zoom > 0.0 then setzoom zoom - | Fn 9 -> togglebirdseye () - | Ascii '9' when ctrl -> togglebirdseye () - | Ascii ('0'..'9' as c) when not ctrl -> - let ondone s = - let n = - try int_of_string s with exn -> - adderrfmt "int_of_string" "`%s': %s" s @@ exntos exn; - -1 - in - if n >= 0 - then ( - addnav (); - cbput !S.hists.pag (string_of_int n); - gotopage1 (n + conf.pagebias - 1) 0; - ) - in - let pageentry text = function [@warning "-fragile-match"] - | Keys.Ascii 'g' -> TEdone text - | key -> intentry text key - in - enttext (":", String.make 1 c, Some (onhist !S.hists.pag), - pageentry, ondone, true) - | Ascii 'b' -> - conf.scrollb <- if conf.scrollb = 0 then (scrollbvv lor scrollbhv) else 0; - Glutils.postRedisplay "toggle scrollbar"; - | Ascii 'B' -> - S.bzoom := not !S.bzoom; - S.rects := []; - showtext ' ' ("block zoom " ^ onoffs !S.bzoom) - | Ascii 'l' -> - conf.hlinks <- not conf.hlinks; - S.text := "highlightlinks " ^ onoffs conf.hlinks; - Glutils.postRedisplay "toggle highlightlinks" - | Ascii 'F' -> - if conf.angle mod 360 = 0 - then ( - S.glinks := true; - let mode = !S.mode in - let te = ("goto: ", E.s, None, linknentry, linknact gotounder, false) in - S.mode := Textentry (te, (fun _ -> S.glinks := false; S.mode := mode)); - S.text := E.s; - Glutils.postRedisplay "view:linkent(F)" - ) - else impmsg "hint mode does not work under rotation" - | Ascii 'y' -> - S.glinks := true; - let mode = !S.mode in - let te = ("copy: ", E.s, None, linknentry, - linknact (fun under -> selstring conf.selcmd (undertext under)), - false) in - S.mode := Textentry (te, (fun _ -> S.glinks := false; S.mode := mode)); - S.text := E.s; - Glutils.postRedisplay "view:linkent" - | Ascii 'a' -> - begin match !S.autoscroll with - | Some step -> - conf.autoscrollstep <- step; - S.autoscroll := None - | None -> S.autoscroll := Some conf.autoscrollstep - end - | Ascii 'p' when ctrl -> launchpath () - | Ascii 'P' -> - setpresentationmode (not conf.presentation); - showtext ' ' ("presentation mode " ^ onoffs conf.presentation) - | Ascii 'f' -> - if List.mem Wsi.Fullscreen !S.winstate - then Wsi.reshape conf.cwinw conf.cwinh - else Wsi.fullscreen () - | Ascii ('p'|'N') -> search !S.searchpattern false - | Ascii 'n' | Fn 3 -> search !S.searchpattern true - | Ascii 't' -> - begin match !S.layout with - | [] -> () - | l :: _ -> gotoxy !S.x (getpagey l.pageno) - end - | Ascii ' ' -> nextpage () - | Delete -> prevpage () - | Ascii '=' -> showtext ' ' (describe_layout !S.layout); - | Ascii 'w' -> - begin match !S.layout with - | [] -> () - | l :: _ -> - Wsi.reshape l.pagew l.pageh; - Glutils.postRedisplay "w" - end - | Ascii '\'' -> enterbookmarkmode () - | Ascii 'i' -> enterinfomode () - | Ascii 'e' when Buffer.length S.errmsgs > 0 -> entermsgsmode () - | Ascii 'm' -> - let ondone s = - match !S.layout with - | l :: _ when nonemptystr s -> addbookmark s @@ getanchor1 l - | _ -> () - in - enttext ("bookmark: ", E.s, None, textentry, ondone, true) - | Ascii '~' -> - quickbookmark (); - showtext ' ' "Quick bookmark added"; - | Ascii 'x' -> !S.roamf () - | Ascii ('<'|'>' as c) -> - reqlayout (conf.angle + (if c = '>' then 30 else -30)) conf.fitmodel - | Ascii ('['|']' as c) -> - conf.colorscale <- - bound (conf.colorscale +. (if c = ']' then 0.1 else -0.1)) 0.0 1.0; - Glutils.postRedisplay "brightness"; - | Ascii 'c' when !S.mode = View -> - if Wsi.withalt mask - then ( - if conf.zoom > 1.0 - then - let m = (!S.winw - !S.w) / 2 in - gotoxy m !S.y - ) - else - let (c, a, b), z = - match !S.prevcolumns with - | None -> (1, 0, 0), 1.0 - | Some (columns, z) -> - let cab = - match columns with - | Csplit (c, _) -> -c, 0, 0 - | Cmulti ((c, a, b), _) -> c, a, b - | Csingle _ -> 1, 0, 0 - in - cab, z - in - setcolumns View c a b; - setzoom z - | Down | Up when ctrl && Wsi.withshift mask -> - let zoom, x = !S.prevzoom in - setzoom zoom; - S.x := x; - | Up -> - begin match !S.autoscroll with - | None -> - begin match !S.mode with - | Birdseye beye -> upbirdseye 1 beye - | Textentry _ | View | LinkNav _ -> - if ctrl - then gotoxy !S.x (U.add_to_y_and_clamp ~-(!S.winh/2)) - else ( - if not (Wsi.withshift mask) && conf.presentation - then prevpage () - else gotoxy !S.x (U.add_to_y_and_clamp (-conf.scrollstep)) - ) - end - | Some n -> setautoscrollspeed n false - end - | Down -> - begin match !S.autoscroll with - | None -> - begin match !S.mode with - | Birdseye beye -> downbirdseye 1 beye - | Textentry _ | View | LinkNav _ -> - if ctrl - then gotoxy !S.x (U.add_to_y_and_clamp (!S.winh/2)) - else ( - if not (Wsi.withshift mask) && conf.presentation - then nextpage () - else gotoxy !S.x (U.add_to_y_and_clamp (conf.scrollstep)) - ) - end - | Some n -> setautoscrollspeed n true - end - | Ascii 'H' -> enterhistmode () - | Fn 1 when Wsi.withalt mask -> enterhistmode () - | Fn 1 -> enterhelpmode () - | Left | Right when not (Wsi.withalt mask) -> - if canpan () - then - let dx = - if ctrl - then !S.winw / 2 - else conf.hscrollstep - in - let dx = - let pv = Wsi.ks2kt key in - if pv = Keys.Left then dx else -dx - in - gotoxy (U.panbound (!S.x + dx)) !S.y - else ( - S.text := E.s; - Glutils.postRedisplay "left/right" - ) - | Prior -> - let y = - if ctrl - then - match !S.layout with - | [] -> !S.y - | l :: _ -> !S.y - l.pagey - else U.add_to_y_and_clamp (U.pgscale ~- !S.winh) - in - gotoxy !S.x y - | Next -> - let y = - if ctrl - then - match List.rev !S.layout with - | [] -> !S.y - | l :: _ -> getpagey l.pageno - else U.add_to_y_and_clamp (U.pgscale !S.winh) - in - gotoxy !S.x y - | Ascii 'g' | Home -> - addnav (); - gotoxy 0 0 - | Ascii 'G' | End -> - addnav (); - gotoxy 0 (U.add_to_y_and_clamp !S.maxy) - | Right when Wsi.withalt mask -> - (match !S.nav.future with - | [] -> () - | next :: frest -> - S.nav := { past = getanchor () :: !S.nav.past; future = frest; }; - gotoxy !S.x (getanchory next) - ) - | Left when Wsi.withalt mask -> histback () - | Backspace -> histback () - | Ascii 'r' -> reload () - | Ascii 'v' when conf.debug -> - S.rects := []; - List.iter (fun l -> - match getopaque l.pageno with - | exception Not_found -> () - | opaque -> - let x0, y0, x1, y1 = Ffi.pagebbox opaque in - let rect = (float x0, float y0, - float x1, float y0, - float x1, float y1, - float x0, float y1) in - debugrect rect; - let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in - S.rects := (l.pageno, color, rect) :: !S.rects; - ) !S.layout; - Glutils.postRedisplay "v"; - | Ascii '|' -> - let mode = !S.mode in - let cmd = ref E.s in - let onleave = function - | Cancel -> S.mode := mode - | Confirm -> - List.iter (fun l -> - match getopaque l.pageno with - | exception Not_found -> () - | opaque -> pipesel opaque !cmd) !S.layout; - S.mode := mode - in - let ondone s = - cbput !S.hists.sel s; - cmd := s - in - let te = - "| ", !cmd, Some (onhist !S.hists.sel), textentry, ondone, true - in - Glutils.postRedisplay "|"; - S.mode := Textentry (te, onleave); - | (Ascii _|Fn _|Enter|Left|Right|Code _|Ctrl _) -> - vlog "huh? %s" (Wsi.keyname key) - -let linknavkeyboard key mask linknav = - let pv = Wsi.ks2kt key in - let getpage pageno = - let rec loop = function - | [] -> None - | l :: _ when l.pageno = pageno -> Some l - | _ :: rest -> loop rest - in loop !S.layout - in - let doexact (pageno, n) = - match getopaque pageno, getpage pageno with - | opaque, Some l -> - if pv = Keys.Enter - then - let under = Ffi.getlink opaque n in - Glutils.postRedisplay "link gotounder"; - gotounder under; - S.mode := View; - else - let opt, dir = - let open Keys in - match pv with - | Home -> Some (Ffi.findlink opaque LDfirst), -1 - | End -> Some (Ffi.findlink opaque LDlast), 1 - | Left -> Some (Ffi.findlink opaque (LDleft n)), -1 - | Right -> Some (Ffi.findlink opaque (LDright n)), 1 - | Up -> Some (Ffi.findlink opaque (LDup n)), -1 - | Down -> Some (Ffi.findlink opaque (LDdown n)), 1 - | Delete|Escape|Insert|Enter|Next|Prior|Ascii _ - | Code _|Fn _|Ctrl _|Backspace -> None, 0 - in - let pwl l dir = - begin match Ffi.findpwl l.pageno dir with - | Pwlnotfound -> () - | Pwl pageno -> - let notfound dir = - S.mode := LinkNav (Ltgendir dir); - let y, h = getpageyh pageno in - let y = - if dir < 0 - then y + h - !S.winh - else y - in - gotoxy !S.x y - in - begin match getopaque pageno, getpage pageno with - | opaque, Some _ -> - let link = - let ld = if dir > 0 then LDfirst else LDlast in - Ffi.findlink opaque ld - in - begin match link with - | Lfound m -> - showlinktype (Ffi.getlink opaque m); - S.mode := LinkNav (Ltexact (pageno, m)); - Glutils.postRedisplay "linknav jpage"; - | Lnotfound -> notfound dir - end; - | _ | exception Not_found -> notfound dir - end; - end; - in - begin match opt with - | Some Lnotfound -> pwl l dir; - | Some (Lfound m) -> - if m = n - then pwl l dir - else ( - let _, y0, _, y1 = Ffi.getlinkrect opaque m in - if y0 < l.pagey - then gotopage1 l.pageno y0 - else ( - let d = fstate.fontsize + 1 in - if y1 - l.pagey > l.pagevh - d - then gotopage1 l.pageno (y1 - !S.winh + d) - else Glutils.postRedisplay "linknav"; - ); - showlinktype (Ffi.getlink opaque m); - S.mode := LinkNav (Ltexact (l.pageno, m)); - ) - - | None -> viewkeyboard key mask - end; - | _ | exception Not_found -> viewkeyboard key mask - in - if pv = Keys.Insert - then ( - begin match linknav with - | Ltexact pa -> S.lnava := Some pa - | Ltgendir _ | Ltnotready _ -> () - end; - S.mode := View; - Glutils.postRedisplay "leave linknav" - ) - else - match linknav with - | Ltgendir _ | Ltnotready _ -> viewkeyboard key mask - | Ltexact exact -> doexact exact - -let keyboard key mask = - if (key = Char.code 'g' && Wsi.withctrl mask) && not (istextentry !S.mode) - then wcmd U.interrupt "" - else !S.uioh#key key mask |> setuioh - -let birdseyekeyboard key mask - ((oconf, leftx, pageno, hooverpageno, anchor) as beye) = - let incr = - match conf.columns with - | Csingle _ -> 1 - | Cmulti ((c, _, _), _) -> c - | Csplit _ -> error "bird's eye split mode" - in - let pgh layout = List.fold_left - (fun m l -> max l.pageh m) !S.winh layout in - let open Keys in - match Wsi.ks2kt key with - | Ascii 'l' when Wsi.withctrl mask -> - let y, h = getpageyh pageno in - let top = (!S.winh - h) / 2 in - gotoxy !S.x (max 0 (y - top)) - | Enter -> leavebirdseye beye false - | Escape -> leavebirdseye beye true - | Up -> upbirdseye incr beye - | Down -> downbirdseye incr beye - | Left -> upbirdseye 1 beye - | Right -> downbirdseye 1 beye - - | Prior -> - begin match !S.layout with - | l :: _ -> - if l.pagey != 0 - then ( - S.mode := Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor); - gotopage1 l.pageno 0; - ) - else ( - let layout = layout !S.x (!S.y - !S.winh) - !S.winw - (pgh !S.layout) in - match layout with - | [] -> gotoxy !S.x (U.add_to_y_and_clamp ~- !S.winh) - | l :: _ -> - S.mode := Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor); - gotopage1 l.pageno 0 - ); - - | [] -> gotoxy !S.x (U.add_to_y_and_clamp ~- !S.winh) - end; - - | Next -> - begin match List.rev !S.layout with - | l :: _ -> - let layout = layout !S.x - (!S.y + (pgh !S.layout)) - !S.winw !S.winh in - begin match layout with - | [] -> - let incr = l.pageh - l.pagevh in - if incr = 0 - then ( - S.mode := - Birdseye ( - oconf, leftx, !S.pagecount - 1, hooverpageno, anchor - ); - Glutils.postRedisplay "birdseye pagedown"; - ) - else - gotoxy !S.x (U.add_to_y_and_clamp (incr + conf.interpagespace*2)); - - | l :: _ -> - S.mode := Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor); - gotopage1 l.pageno 0; - end - - | [] -> gotoxy !S.x (U.add_to_y_and_clamp !S.winh) - end; - - | Home -> - S.mode := Birdseye (oconf, leftx, 0, hooverpageno, anchor); - gotopage1 0 0 - - | End -> - let pageno = !S.pagecount - 1 in - S.mode := Birdseye (oconf, leftx, pageno, hooverpageno, anchor); - if not (U.pagevisible !S.layout pageno) - then - let h = - match List.rev !S.pdims with - | [] -> !S.winh - | (_, _, h, _) :: _ -> h - in - gotoxy - !S.x - (max 0 (getpagey pageno - (!S.winh - h - conf.interpagespace))) - else Glutils.postRedisplay "birdseye end"; - - | Delete|Insert|Ascii _|Code _|Ctrl _|Fn _|Backspace -> viewkeyboard key mask - -let drawpage l = - let color = - match !S.mode with - | Textentry _ -> U.scalecolor 0.4 - | LinkNav _ | View -> U.scalecolor 1.0 - | Birdseye (_, _, pageno, hooverpageno, _) -> - if l.pageno = hooverpageno - then U.scalecolor 0.9 - else ( - if l.pageno = pageno - then ( - let c = U.scalecolor 1.0 in - GlDraw.color c; - GlDraw.line_width 3.0; - let dispx = l.pagedispx in - Glutils.linerect - (float (dispx-1)) (float (l.pagedispy-1)) - (float (dispx+l.pagevw+1)) - (float (l.pagedispy+l.pagevh+1)); - GlDraw.line_width 1.0; - c; - ) - else U.scalecolor 0.8 - ) - in - drawtiles l color - -let postdrawpage l linkindexbase = - match getopaque l.pageno with - | exception Not_found -> 0 - | opaque -> - if tileready l l.pagex l.pagey - then - let x = l.pagedispx - l.pagex - and y = l.pagedispy - l.pagey in - let hlmask = - match conf.columns with - | Csingle _ | Cmulti _ -> - (if conf.hlinks then 1 else 0) - + (if !S.glinks - && not (isbirdseye !S.mode) then 2 else 0) - | Csplit _ -> 0 - in - let s = - match !S.mode with - | Textentry ((_, s, _, _, _, _), _) when !S.glinks -> s - | Textentry _ - | Birdseye _ - | View - | LinkNav _ -> E.s - in - let n = - Ffi.postprocess opaque hlmask x y - (linkindexbase, s, conf.hfsize, conf.hcs) in - if n < 0 - then (Glutils.redisplay := not @@ hasdata !S.ss; 0) - else n - else 0 - -let scrollindicator () = - let sbw, ph, sh = !S.uioh#scrollph in - let sbh, pw, sw = !S.uioh#scrollpw in - - let x0,x1,hx0 = - if conf.leftscroll - then (0, sbw, sbw) - else ((!S.winw - sbw), !S.winw, 0) - in - - Gl.enable `blend; - GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; - let (r, g, b, alpha) = conf.sbarcolor in - GlDraw.color (r, g, b) ~alpha; - Glutils.filledrect (float x0) 0. (float x1) (float !S.winh); - Glutils.filledrect - (float hx0) (float (!S.winh - sbh)) - (float (hx0 + !S.winw)) (float !S.winh); - let (r, g, b, alpha) = conf.sbarhndlcolor in - GlDraw.color (r, g, b) ~alpha; - - Glutils.filledrect (float x0) ph (float x1) (ph +. sh); - let pw = pw +. float hx0 in - Glutils.filledrect pw (float (!S.winh - sbh)) (pw +. sw) (float !S.winh); - Gl.disable `blend - -let showsel () = - match !S.mstate with - | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ -> () - | Msel ((x0, y0), (x1, y1)) -> - let identify opaque l px py = Some (opaque, l.pageno, px, py) in - let o0,n0,px0,py0 = - onppundermouse identify x0 y0 (Opaque.of_string E.s, -1, 0, 0) in - let _o1,n1,px1,py1 = - onppundermouse identify x1 y1 (Opaque.of_string E.s, -1, 0, 0) in - if n0 != -1 && n0 = n1 then Ffi.seltext o0 (px0, py0, px1, py1) - -let showrects = function - | [] -> () - | rects -> - Gl.enable `blend; - GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5; - GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; - List.iter - (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) -> - List.iter (fun l -> - if l.pageno = pageno - then - let dx = float (l.pagedispx - l.pagex) in - let dy = float (l.pagedispy - l.pagey) in - let r, g, b, alpha = c in - GlDraw.color (r, g, b) ~alpha; - Glutils.filledrect2 - (x0+.dx) (y0+.dy) - (x1+.dx) (y1+.dy) - (x3+.dx) (y3+.dy) - (x2+.dx) (y2+.dy); - ) !S.layout - ) rects; - Gl.disable `blend - -let display () = - let sc (r, g, b) = let s = conf.colorscale in (r *. s, g *. s, b *. s) in - GlDraw.color (sc conf.bgcolor); - GlClear.color (sc conf.bgcolor); - GlClear.clear [`color]; - List.iter drawpage !S.layout; - let rects = - match !S.mode with - | LinkNav (Ltgendir _) | LinkNav (Ltnotready _) - | Birdseye _ - | Textentry _ - | View -> !S.rects - | LinkNav (Ltexact (pageno, linkno)) -> - match getopaque pageno with - | exception Not_found -> !S.rects - | opaque -> - let x0, y0, x1, y1 = Ffi.getlinkrect opaque linkno in - let color = - if conf.invert - then (1.0, 1.0, 1.0, 0.5) - else (0.0, 0.0, 0.5, 0.5) - in - (pageno, color, - (float x0, float y0, - float x1, float y0, - float x1, float y1, - float x0, float y1) - ) :: !S.rects - in - showrects rects; - let rec postloop linkindexbase = function - | l :: rest -> - let linkindexbase = linkindexbase + postdrawpage l linkindexbase in - postloop linkindexbase rest - | [] -> () - in - showsel (); - postloop 0 !S.layout; - !S.uioh#display; - begin match !S.mstate with - | Mzoomrect ((x0, y0), (x1, y1)) -> - Gl.enable `blend; - GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5; - GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; - Glutils.filledrect (float x0) (float y0) (float x1) (float y1); - Gl.disable `blend; - | Msel _ - | Mpan _ - | Mscrolly | Mscrollx - | Mzoom _ - | Mnone -> () - end; - enttext (); - scrollindicator (); - - if conf.pgscale > 0.0 - then ( - let drawsep y = - let x0 = 0.0 and y0 = y -. 3.0 in - let x1 = float !S.winw and y1 = y +. 3.0 in - Glutils.filledrect x0 y0 x1 y1; - in - Gl.enable `blend; - GlDraw.color (0.1, 0.1, 0.1) ~alpha:0.5; - GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; - (match !S.layout with - | _ :: [] -> drawsep (conf.pgscale *. float !S.winh) - | l -> List.iter (fun p -> drawsep (float (p.pagedispy+p.pagevh))) l - ); - Gl.disable `blend; - ); - Wsi.swapb () - -let display () = - match !S.reload with - | Some (x, y, t) -> - if x != !S.x || y != !S.y || abs_float @@ now () -. t > 0.5 - || (!S.layout != [] && alltilesrendered !S.layout) - then ( - S.reload := None; - display () - ) - | None -> display () - -let zoomrect x y x1 y1 = - let x0 = min x x1 - and x1 = max x x1 - and y0 = min y y1 in - let zoom = (float !S.w) /. float (x1 - x0) in - let margin = - let simple () = - if !S.w < !S.winw - then (!S.winw - !S.w) / 2 - else 0 - in - match conf.fitmodel with - | FitWidth | FitProportional -> simple () - | FitPage -> - match conf.columns with - | Csplit _ -> - onppundermouse (fun _ l _ _ -> Some l.pagedispx) x0 y0 x0 - | Cmulti _ | Csingle _ -> simple () - in - gotoxy ((!S.x + margin) - x0) (!S.y + y0); - S.anchor := getanchor (); - setzoom zoom; - resetmstate () - -let annot inline x y = - match unproject x y with - | Some (opaque, n, ux, uy) -> - let add text = - Ffi.addannot opaque ux uy text; - wcmd1 U.freepage opaque; - Hashtbl.remove S.pagemap (n, !S.gen); - flushtiles (); - gotoxy !S.x !S.y - in - if inline - then - let mode = !S.mode in - let te = ("annotation: ", E.s, None, textentry, add, true) in - S.mode := Textentry (te, fun _ -> S.mode := mode); - S.text := E.s; - enttext (); - Glutils.postRedisplay "annot" - else add @@ getusertext E.s - | _ -> () - -let zoomblock x y = - let g opaque l px py = - match Ffi.rectofblock opaque px py with - | Some a -> - let x0 = a.(0) -. 20. in - let x1 = a.(1) +. 20. in - let y0 = a.(2) -. 20. in - let zoom = (float !S.w) /. (x1 -. x0) in - let pagey = getpagey l.pageno in - let margin = (!S.w - l.pagew)/2 in - let nx = -truncate x0 - margin in - gotoxy nx (pagey + truncate y0); - S.anchor := getanchor (); - setzoom zoom; - None - | None -> None - in - match conf.columns with - | Csplit _ -> - impmsg "block zooming while in split columns mode is not implemented" - | Cmulti _ | Csingle _ -> onppundermouse g x y () - -let scrollx x = - let winw = !S.winw - 1 in - let s = float x /. float winw in - let destx = truncate (float (!S.w + winw) *. s) in - gotoxy (winw - destx) !S.y; - S.mstate := Mscrollx - -let scrolly y = - let s = float y /. float !S.winh in - let desty = truncate (s *. float (U.maxy ())) in - gotoxy !S.x desty; - S.mstate := Mscrolly - -let viewmulticlick clicks x y mask = - let g opaque l px py = - let mark = - match clicks with - | 2 -> MarkWord - | 3 -> MarkLine - | 4 -> MarkBlock - | _ -> MarkPage - in - if Ffi.markunder opaque px py mark - then ( - Some (fun () -> - let dopipe cmd = - match getopaque l.pageno with - | exception Not_found -> () - | opaque -> pipesel opaque cmd - in - S.roamf := (fun () -> dopipe conf.paxcmd); - if not (Wsi.withctrl mask) then dopipe conf.selcmd; - ) - ) - else None - in - Glutils.postRedisplay "viewmulticlick"; - onppundermouse g x y (fun () -> impmsg "nothing to select") () - -let canselect () = conf.angle mod 360 = 0 - -let viewmouse button down x y mask = - match button with - | n when (n == 4 || n == 5) && not (Wsi.withshift mask) && not down -> - if Wsi.withctrl mask - then ( - let incr = - if n = 5 - then if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 - else if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1 - in - let fx, fy = - match !S.mstate with - | Mzoom (oldn, _, pos) when n = oldn -> pos - | Mzoomrect _ | Mnone | Mpan _ - | Msel _ | Mscrollx | Mscrolly | Mzoom _ -> (x, y) - in - let zoom = conf.zoom -. incr in - S.mstate := Mzoom (n, 0, (x, y)); - if false && abs (fx - x) > 5 || abs (fy - y) > 5 - then pivotzoom ~x ~y zoom - else pivotzoom zoom - ) - else ( - match !S.autoscroll with - | Some step -> setautoscrollspeed step (n=4) - | None -> - if conf.wheelbypage || conf.presentation - then ( - if n = 4 - then prevpage () - else nextpage () - ) - else - let incr = if n = 4 then -conf.scrollstep else conf.scrollstep in - let incr = incr * 2 in - let y = U.add_to_y_and_clamp incr in - gotoxy !S.x y - ) - - | n when (n = 4 || n = 5 || n = 6 || n = 7) && not down && canpan () -> - let x = U.panbound - (!S.x + (if n = 5 || n = 7 then -2 else 2) * conf.hscrollstep) - in - gotoxy x !S.y - - | 1 when Wsi.withshift mask -> - S.mstate := Mnone; - if not down - then ( - match unproject x y with - | None -> () - | Some (_, pageno, ux, uy) -> - let cmd = Printf.sprintf "%s %s %d %d %d" conf.stcmd !S.path - pageno ux uy - in - match spawn cmd [] with - | exception exn -> - adderrfmt "spawn" "execution of synctex command(%S) failed: %S" - conf.stcmd @@ exntos exn - | _pid -> () - ) - - | 1 when Wsi.withctrl mask -> - if down - then ( - Wsi.setcursor Wsi.CURSOR_FLEUR; - S.mstate := Mpan (x, y) - ) - else S.mstate := Mnone - - | 3 -> - if down - then ( - if Wsi.withshift mask - then ( - annot conf.annotinline x y; - Glutils.postRedisplay "addannot" - ) - else - let p = (x, y) in - Wsi.setcursor Wsi.CURSOR_CYCLE; - S.mstate := Mzoomrect (p, p) - ) - else ( - match !S.mstate with - | Mzoomrect ((x0, y0), _) -> - if abs (x-x0) > 10 && abs (y - y0) > 10 - then zoomrect x0 y0 x y - else ( - resetmstate (); - Glutils.postRedisplay "kill accidental zoom rect"; - ) - | Msel _ - | Mpan _ - | Mscrolly | Mscrollx - | Mzoom _ - | Mnone -> resetmstate () - ) - - | 1 when vscrollhit x -> - if down - then - let _, position, sh = !S.uioh#scrollph in - if y > truncate position && y < truncate (position +. sh) - then S.mstate := Mscrolly - else scrolly y - else S.mstate := Mnone - - | 1 when y > !S.winh - hscrollh () -> - if down - then - let _, position, sw = !S.uioh#scrollpw in - if x > truncate position && x < truncate (position +. sw) - then S.mstate := Mscrollx - else scrollx x - else S.mstate := Mnone - - | 1 when !S.bzoom -> if not down then zoomblock x y - - | 1 -> - let dest = if down then getunder x y else Unone in - begin match dest with - | Ulinkuri _ -> gotounder dest - | Unone when down -> - Wsi.setcursor Wsi.CURSOR_FLEUR; - S.mstate := Mpan (x, y); - | Utextannot (opaque, slinkindex) -> enterannotmode opaque slinkindex - | Unone | Utext _ | Ufileannot _ -> - if down - then ( - if canselect () - then ( - S.mstate := Msel ((x, y), (x, y)); - Glutils.postRedisplay "mouse select"; - ) - ) - else ( - match !S.mstate with - | Mnone -> () - | Mzoom _ | Mscrollx | Mscrolly -> S.mstate := Mnone - | Mzoomrect ((x0, y0), _) -> zoomrect x0 y0 x y - | Mpan _ -> - Wsi.setcursor Wsi.CURSOR_INHERIT; - S.mstate := Mnone - | Msel ((x0, y0), (x1, y1)) -> - let rec loop = function - | [] -> () - | l :: rest -> - let inside = - let a0 = l.pagedispy in - let a1 = a0 + l.pagevh in - let b0 = l.pagedispx in - let b1 = b0 + l.pagevw in - ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1)) - && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1)) - in - if inside - then - match getopaque l.pageno with - | exception Not_found -> () - | opaque -> - let dosel cmd () = - pipef ~closew:false "Msel" - (fun w -> - Ffi.copysel w opaque; - Glutils.postRedisplay "Msel") cmd - in - dosel conf.selcmd (); - S.roamf := dosel conf.paxcmd; - else loop rest - in - loop !S.layout; - resetmstate (); - ) - end - | _ -> () - -let birdseyemouse button down x y mask - (conf, leftx, _, hooverpageno, anchor) = - match button with - | 1 when down -> - let rec loop = function - | [] -> () - | l :: rest -> - if y > l.pagedispy && y < l.pagedispy + l.pagevh - && x > l.pagedispx && x < l.pagedispx + l.pagevw - then - leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false - else loop rest - in - loop !S.layout - | 3 -> () - | _ -> viewmouse button down x y mask - -let uioh = object - method display = () - method infochanged _ = () - - method key key mask = - begin match !S.mode with - | Textentry textentry -> textentrykeyboard key mask textentry - | Birdseye birdseye -> birdseyekeyboard key mask birdseye - | View -> viewkeyboard key mask - | LinkNav linknav -> linknavkeyboard key mask linknav - end; - !S.uioh - - method button button bstate x y mask = - begin match !S.mode with - | LinkNav _ | View -> viewmouse button bstate x y mask - | Birdseye beye -> birdseyemouse button bstate x y mask beye - | Textentry _ -> () - end; - !S.uioh - - method multiclick clicks x y mask = - begin match !S.mode with - | LinkNav _ | View -> viewmulticlick clicks x y mask - | Birdseye _ | Textentry _ -> () - end; - !S.uioh - - method motion x y = - begin match !S.mode with - | Textentry _ -> () - | View | Birdseye _ | LinkNav _ -> - match !S.mstate with - | Mzoom _ | Mnone -> () - | Mpan (x0, y0) -> - let dx = x - x0 - and dy = y0 - y in - S.mstate := Mpan (x, y); - let x = if canpan () then U.panbound (!S.x + dx) else !S.x in - let y = U.add_to_y_and_clamp dy in - gotoxy x y - - | Msel (a, _) -> - S.mstate := Msel (a, (x, y)); - Glutils.postRedisplay "motion select"; - - | Mscrolly -> - let y = min !S.winh (max 0 y) in - scrolly y - - | Mscrollx -> - let x = min !S.winw (max 0 x) in - scrollx x - - | Mzoomrect (p0, _) -> - S.mstate := Mzoomrect (p0, (x, y)); - Glutils.postRedisplay "motion zoomrect"; - end; - !S.uioh - - method pmotion x y = - begin match !S.mode with - | Birdseye (conf, leftx, pageno, hooverpageno, anchor) -> - let rec loop = function - | [] -> - if hooverpageno != -1 - then ( - S.mode := Birdseye (conf, leftx, pageno, -1, anchor); - Glutils.postRedisplay "pmotion birdseye no hoover"; - ) - | l :: rest -> - if y > l.pagedispy && y < l.pagedispy + l.pagevh - && x > l.pagedispx && x < l.pagedispx + l.pagevw - then ( - S.mode := Birdseye (conf, leftx, pageno, l.pageno, anchor); - Glutils.postRedisplay "pmotion birdseye hoover"; - ) - else loop rest - in - loop !S.layout - - | Textentry _ -> () - - | LinkNav _ | View -> - match !S.mstate with - | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ -> () - | Mnone -> - updateunder x y; - if canselect () - then - match conf.pax with - | None -> () - | Some past -> - let now = now () in - let delta = now -. past in - if delta > 0.01 - then paxunder x y - else conf.pax <- Some now - end; - !S.uioh - - method scrollph = - let maxy = U.maxy () in - let p, h = - if maxy = 0 - then 0.0, float !S.winh - else scrollph !S.y maxy - in - vscrollw (), p, h - - method scrollpw = - let fwinw = float (!S.winw - vscrollw ()) in - let sw = - let sw = fwinw /. float !S.w in - let sw = fwinw *. sw in - max sw (float conf.scrollh) - in - let position = - let maxx = !S.w + !S.winw in - let x = !S.winw - !S.x in - let percent = float x /. float maxx in - (fwinw -. sw) *. percent - in - hscrollh (), position, sw - - method modehash = - let modename = - match !S.mode with - | LinkNav _ -> "links" - | Textentry _ -> "textentry" - | Birdseye _ -> "birdseye" - | View -> "view" - in - findkeyhash conf modename - - method eformsgs = true - method alwaysscrolly = false - method scroll dx dy = - let x = if canpan () then U.panbound (!S.x + dx) else !S.x in - gotoxy x (U.add_to_y_and_clamp (2 * dy)); - !S.uioh - method zoom z x y = - pivotzoom ~x ~y (conf.zoom *. exp z); - end - -let ract cmds = - let cl = splitatchar cmds ' ' in - let scan s fmt f = - try Scanf.sscanf s fmt f - with exn -> adderrfmt "remote exec" "error processing '%S': %s\n" - cmds @@ exntos exn - in - let rectx s pageno (r, g, b, a) x0 y0 x1 y1 = - vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f" - s pageno r g b a x0 y0 x1 y1; - onpagerect - pageno - (fun w h -> - let _,w1,h1,_ = getpagedim pageno in - let sw = float w1 /. float w - and sh = float h1 /. float h in - let x0s = x0 *. sw - and x1s = x1 *. sw - and y0s = y0 *. sh - and y1s = y1 *. sh in - let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in - let color = (r, g, b, a) in - if conf.verbose then debugrect rect; - S.rects := (pageno, color, rect) :: !S.rects; - Glutils.postRedisplay s; - ) - in - match cl with - | "reload", "" -> reload () - | "goto", args -> - scan args "%u %f %f" - (fun pageno x y -> - let cmd, _ = !S.geomcmds in - if emptystr cmd - then gotopagexy pageno x y - else - let f prevf () = - gotopagexy pageno x y; - prevf () - in - S.reprf := f !S.reprf - ) - | "goto1", args -> scan args "%u %f" gotopage - | "gotor", args -> scan args "%S" gotoremote - | "rect", args -> - scan args "%u %u %f %f %f %f" - (fun pageno c x0 y0 x1 y1 -> - let color = (0.0, 0.0, 1.0 /. float c, 0.5) in - rectx "rect" pageno color x0 y0 x1 y1; - ) - | "pgoto", args -> - scan args "%u %f %f" - (fun pageno x y -> - let optopaque = - match getopaque pageno with - | exception Not_found -> Opaque.of_string E.s - | opaque -> opaque - in - pgoto optopaque pageno x y; - let rec fixx = function - | [] -> () - | l :: rest -> - if l.pageno = pageno - then gotoxy (!S.x - l.pagedispx) !S.y - else fixx rest - in - let layout = - let mult = - match conf.columns with - | Csingle _ | Csplit _ -> 1 - | Cmulti ((n, _, _), _) -> n - in - layout 0 !S.y (!S.winw * mult) !S.winh - in - fixx layout - ) - | "activatewin", "" -> Wsi.activatewin () - | "quit", "" -> raise Quit - | "keys", keys -> - begin try - let l = Config.keys_of_string keys in - List.iter (fun (k, m) -> keyboard k m) l - with exn -> adderrfmt "error processing keys" "`%S': %s\n" - cmds @@ exntos exn - end - | _ -> - adderrfmt "remote command" - "error processing remote command: %S\n" cmds - -let remote = - let scratch = Bytes.create 80 in - let buf = Buffer.create 80 in - fun fd -> - match tempfailureretry (Unix.read fd scratch 0) 80 with - | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> None - | 0 -> - Unix.close fd; - if Buffer.length buf > 0 - then ( - let s = Buffer.contents buf in - Buffer.clear buf; - ract s; - ); - None - | n -> - let rec eat ppos = - let nlpos = - match Bytes.index_from scratch ppos '\n' with - | exception Not_found -> -1 - | pos -> if pos >= n then -1 else pos - in - if nlpos >= 0 - then ( - Buffer.add_subbytes buf scratch ppos (nlpos-ppos); - let s = Buffer.contents buf in - Buffer.clear buf; - ract s; - eat (nlpos+1); - ) - else ( - Buffer.add_subbytes buf scratch ppos (n-ppos); - Some fd - ) - in eat 0 - -let remoteopen path = - try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0) - with exn -> - adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn; - None - -let () = - vlogf := (fun s -> if conf.verbose then print_endline s else ignore s); - S.redirstderr := not @@ Unix.isatty Unix.stderr; - let gc = ref false in - let rcmdpath = ref E.s in - let dcfpath = ref E.s in - let pageno = ref None in - let openlast = ref false in - let doreap = ref false in - let csspath = ref None in - let justversion = ref false in - S.selfexec := Sys.executable_name; - let spec = - [("-p", Arg.Set_string S.password, " Set password"); - ("-f", Arg.String - (fun s -> - S.fontpath := s; - S.selfexec := !S.selfexec ^ " -f " ^ Filename.quote s; - ), " Set path to the user interface font"); - ("-c", Arg.String - (fun s -> - S.selfexec := !S.selfexec ^ " -c " ^ Filename.quote s; - S.confpath := s), " Set path to the configuration file"); - ("-last", Arg.Set openlast, " Open last document"); - ("-page", Arg.Int (fun pageno1 -> pageno := Some (pageno1-1)), - " Jump to page"); - ("-dest", Arg.Set_string S.nameddest, - " Set named destination"); - ("-remote", Arg.Set_string rcmdpath, - " Set path to the remote fifo"); - ("-gc", Arg.Set gc, " Collect garbage"); - ("-v", Arg.Set justversion, " Print version and exit"); - ("-css", Arg.String (fun s -> csspath := Some s), - " Set path to the style sheet to use with EPUB/HTML"); - ("-origin", Arg.Set_string S.origin, " "); - ("-no-title", Arg.Set S.ignoredoctitlte, " Ignore document title"); - ("-dcf", Arg.Set_string dcfpath, " "); - ("-flip-stderr-redirection", - Arg.Unit (fun () -> S.redirstderr := not !S.redirstderr), - " "); - ("-mime", Arg.Set_string S.mimetype, " ") - ] - in - Arg.parse (Arg.align spec) (fun s -> S.path := s) - ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:"); - - if !S.confpath == E.s - then ( - let dir = - let dir = Filename.concat home ".config" in - if try Sys.is_directory dir with _ -> false then dir else home - in - S.confpath := Filename.concat dir "llpp.conf" - ); - - if !justversion - then Printf.( - printf "%s\nconfiguration file: %s\n" (Help.version ()) !S.confpath; - exit 0 - ); - - let histmode = emptystr !S.path && not !openlast in - - if !gc - then ( - Config.gc (); - if histmode then exit 0; - ); - - if not (Config.load !openlast) - then dolog "failed to load configuration"; - - if nonemptystr !dcfpath - then conf.dcf <- !dcfpath; - - begin match !pageno with - | Some pageno -> S.anchor := (pageno, 0.0, 0.0) - | None -> () - end; - - fillhelp (); - let mu = - object (self) - val mutable m_clicks = 0 - val mutable m_click_x = 0 - val mutable m_click_y = 0 - val mutable m_lastclicktime = infinity - - method private cleanup = - S.roamf := noroamf; - Hashtbl.iter (fun _ opaque -> Ffi.clearmark opaque) S.pagemap - method expose = Glutils.postRedisplay "expose" - method visible v = - let name = - match v with - | Wsi.Unobscured -> "unobscured" - | Wsi.PartiallyObscured -> "partiallyobscured" - | Wsi.FullyObscured -> "fullyobscured" - in - vlog "visibility change %s" name - method display = display () - method map mapped = vlog "mapped %b" mapped - method reshape w h = - self#cleanup; - reshape w h - method mouse b d x y m = - (*http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx*) - m_click_x <- x; - setuioh @@ - if d && canselect () - then ( - m_click_y <- y; - if b = 1 - then ( - let t = now () in - if abs x - m_click_x > 10 - || abs y - m_click_y > 10 - || abs_float (t -. m_lastclicktime) > 0.3 - then m_clicks <- 0; - m_clicks <- m_clicks + 1; - m_lastclicktime <- t; - if m_clicks = 1 - then ( - self#cleanup; - Glutils.postRedisplay "cleanup"; - !S.uioh#button b d x y m - ) - else !S.uioh#multiclick m_clicks x y m - ) - else ( - self#cleanup; - m_clicks <- 0; - m_lastclicktime <- infinity; - !S.uioh#button b d x y m - ); - ) - else !S.uioh#button b d x y m - method motion x y = - S.mpos := (x, y); - !S.uioh#motion x y |> setuioh - method pmotion x y = - S.mpos := (x, y); - !S.uioh#pmotion x y |> setuioh - method key k m = - vlog "k=%#x m=%#x" k m; - let mascm = m land ( - Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask - ) in - let keyboard k m = - let x = !S.x and y = !S.y in - keyboard k m; - if x != !S.x || y != !S.y then self#cleanup - in - match !S.keystate with - | KSnone -> - let km = k, mascm in - begin - match - let modehash = !S.uioh#modehash in - try Hashtbl.find modehash km - with Not_found -> - try Hashtbl.find (findkeyhash conf "global") km - with Not_found -> KMinsrt (k, m) - with - | KMinsrt (k, m) -> keyboard k m - | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l - | KMmulti (l, r) -> S.keystate := KSinto (l, r) - end - | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' -> - List.iter (fun (k, m) -> keyboard k m) insrt; - S.keystate := KSnone - | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' -> - S.keystate := KSinto (keys, insrt) - | KSinto _ -> S.keystate := KSnone - method enter x y = - S.mpos := (x, y); - !S.uioh#pmotion x y |> setuioh - method leave = S.mpos := (-1, -1) - method winstate wsl = S.winstate := wsl - method quit : 'a. 'a = raise Quit - method scroll dx dy = - !S.uioh#scroll dx dy |> setuioh - method zoom z x y = !S.uioh#zoom z x y - method opendoc path = - S.mode := View; - setuioh uioh; - Glutils.postRedisplay "opendoc"; - opendoc path !S.mimetype !S.password - end - in - let wsfd, winw, winh = Wsi.init mu conf.cwinw conf.cwinh in - S.wsfd := wsfd; - - let cs, ss = - match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with - | exception exn -> - dolog "socketpair failed: %s" @@ exntos exn; - exit 1 - | (r, w) -> - Unix.set_close_on_exec r; - Unix.set_close_on_exec w; - r, w - in - - begin match !csspath with - | None -> () - | Some "" -> conf.css <- E.s - | Some path -> - let css = filecontents path in - let l = String.length css in - conf.css <- - if l > 1 && substratis css (l-2) "\r\n" - then String.sub css 0 (l-2) - else (if l > 0 && css.[l-1] = '\n' then String.sub css 0 (l-1) else css) - end; - S.stderr := Ffi.init cs ( - conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz), - conf.texcount, conf.sliceheight, conf.mustoresize, - conf.colorspace, !S.fontpath, !S.redirstderr - ); - List.iter GlArray.enable [`texture_coord; `vertex]; - GlTex.env (`color conf.texturecolor); - S.ss := ss; - reshape ~firsttime:true winw winh; - setuioh uioh; - if histmode - then (Wsi.settitle "previously visited - llpp"; enterhistmode ()) - else opendoc !S.path !S.mimetype !S.password; - display (); - Wsi.mapwin (); - Wsi.setcursor Wsi.CURSOR_INHERIT; - Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ())); - - let rec reap () = - match Unix.waitpid [Unix.WNOHANG] ~-1 with - | exception (Unix.Unix_error (Unix.ECHILD, _, _)) -> () - | exception exn -> dolog "Unix.waitpid: %s" @@ exntos exn - | 0, _ -> () - | _pid, _status -> reap () - in - Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> doreap := true)); - - let optrfd = - ref (if nonemptystr !rcmdpath then remoteopen !rcmdpath else None) - in - if !S.redirstderr - then dologf := (adderrfmt "stderr" "%s\n"); - - let fdl = - let l = [!S.ss; !S.wsfd] in if !S.redirstderr then !S.stderr :: l else l - in - let rec loop deadline = - if !doreap - then ( - doreap := false; - reap () - ); - let r = - match !optrfd with - | None -> fdl - | Some fd -> fd :: fdl - in - if !Glutils.redisplay - then ( - Glutils.redisplay := false; - display (); - ); - let timeout = - let now = now () in - if deadline > now - then ( - if deadline = infinity - then ~-.1.0 - else max 0.0 (deadline -. now) - ) - else 0.0 - in - let r, _, _ = - try Unix.select r [] [] timeout - with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], [] - in - begin match r with - | [] -> - let newdeadline = - match !S.autoscroll with - | Some step when step != 0 -> - let y = !S.y + step in - let fy = if conf.maxhfit then !S.winh else 0 in - let y = - if y < 0 - then !S.maxy - fy - else - if y >= !S.maxy - fy - then 0 - else y - in - gotoxy !S.x y; - deadline +. 0.01 - | _ -> infinity - in - loop newdeadline - - | l -> - let rec checkfds = function - | [] -> () - | fd :: rest when fd = !S.ss -> - let cmd = Ffi.rcmd !S.ss in - act cmd; - checkfds rest - - | fd :: rest when fd = !S.wsfd -> - Wsi.readresp fd; - checkfds rest - - | fd :: rest when fd = !S.stderr -> - let b = Bytes.create 80 in - begin match Unix.read fd b 0 80 with - | exception Unix.Unix_error (Unix.EINTR, _, _) -> () - | exception exn -> adderrmsg "Unix.read exn" @@ exntos exn - | 0 -> () - | n -> adderrmsg "stderr" @@ Bytes.sub_string b 0 n - end; - checkfds rest - - | fd :: rest when Some fd = !optrfd -> - begin match remote fd with - | None -> optrfd := remoteopen !rcmdpath; - | opt -> optrfd := opt - end; - checkfds rest - - | _ :: rest -> - adderrmsg "mainloop" "select returned unknown descriptor"; - checkfds rest - in - checkfds l; - let newdeadline = - match !S.autoscroll with - | Some step when step != 0 -> - if deadline = infinity - then now () +. 0.01 - else deadline - | _ -> infinity - in - loop newdeadline - end; - in - match loop infinity with - | exception Quit -> - (match Buffer.length S.errmsgs with - | 0 -> () - | n -> - match Unix.write Unix.stdout (Buffer.to_bytes S.errmsgs) 0 n with - | exception _ | _ -> ()); - Config.save leavebirdseye; - if Ffi.hasunsavedchanges () - then save () - | _ -> error "umpossible - infinity reached" diff --git a/main.mli b/main.mli deleted file mode 100644 index e69de29..0000000 diff --git a/misc/bistep b/misc/bistep deleted file mode 100755 index c9ba4b5..0000000 --- a/misc/bistep +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/sh -set -eu -ulimit -s 7032 -rm -fr build/bisect -mkdir build/bisect -ln -s $PWD/build/mupdf $PWD/build/bisect/ - -{ - pushd ~/x/rcs/git/ocaml - git clean -dfx - CC='ccache gcc' ./configure --disable-ocamldoc --disable-ocamltest \ - --enable-debugger=no --prefix=$PWD/build/bisect - make -j4 - make -s install - popd -} - -bash build.bash build/bisect diff --git a/misc/completions/zsh/_llpp b/misc/completions/zsh/_llpp deleted file mode 100644 index 9f56a14..0000000 --- a/misc/completions/zsh/_llpp +++ /dev/null @@ -1,4 +0,0 @@ -#compdef llpp - -_arguments -s \ - '*::document:_files -g "*.(pdf|xps|zip|cbz|png|jpg|jpeg|jpe|jpx|gif|bmp|jpx|jp2|j2k|hdp|jxr|pbm|pgm|ppm|pam|pnm|epub|tiff|tif|svg|fb2|html|htm|xhtml|wdp)"' diff --git a/misc/completions/zsh/_llppac b/misc/completions/zsh/_llppac deleted file mode 100644 index 5642c91..0000000 --- a/misc/completions/zsh/_llppac +++ /dev/null @@ -1,7 +0,0 @@ -#compdef llppac - -_arguments -s \ - '-m[Mime/type]:mime:_mime_types' \ - '-t[Filter]' \ - '-f[Force]' \ - '*::document:_files -g "*.(pdf|xps|zip|cbz|jpg|jpeg|png|epub|gz|Z|xz|bz2|ps|eps|djv|djvu|dvi|doc|docx|ppt|pptx|xls|odf|odg|odp|ods|odt|md|bmp|gif|pbm|ppm|pgm|svg|svgz|tif|tiff|xbm|xpm|xcf|arw|cr2|crw|nef|nrw|raf|raw|x3f|otf|ttf|ttc|otc)"' diff --git a/misc/cutrel b/misc/cutrel deleted file mode 100755 index d24f27d..0000000 --- a/misc/cutrel +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -set -e -range="$1..${2-HEAD}" -(echo "Summary $range" - git shortlog --no-merges -ns $range - printf "\nDiffstat $range\n" - git diff --stat $range) | xclip -i -xclip -o diff --git a/misc/gcext.py b/misc/gcext.py deleted file mode 100644 index 110d412..0000000 --- a/misc/gcext.py +++ /dev/null @@ -1,58 +0,0 @@ -import argparse -import os -import xml.etree.ElementTree as ET - -parser = argparse.ArgumentParser() -parser.add_argument( - '-i', - dest='input', - type=str, - metavar='SOURCE', - help='path to your llpp.conf; default to ~/.config/llpp.conf', - default='~/.config/llpp.conf') -parser.add_argument( - '-d', - dest='timestamp', - type=int, - help='entries saved earlier than this date will be removed') -parser.add_argument( - '-k', - dest='keyword', - type=str, - help='entries with path matching the keyword will be removed') -parser.add_argument(dest='dest', - type=str, - metavar='DEST', - help='path to output config file') - -args = parser.parse_args() -source = args.input -cts = args.timestamp -keyword = args.keyword -dest = args.dest - -tree = ET.parse(os.path.expanduser(source)) -root = tree.getroot() - -print('Removing the following entries in llpp.conf:') -i = 0 -for doc in root.findall('doc'): - # skip entries with bookmarks - if doc.find('bookmarks'): - continue - # remove entries older than 2019.9.1 - ts = int(doc.get('last-visit')) - if cts is not None and ts < cts: - print(doc.get('path')) - root.remove(doc) - i += 1 - continue - # remove entries whose path contains the keyword - if keyword is not None and keyword in doc.get('path'): - print(doc.get('path')) - root.remove(doc) - i += 1 - -print(i, 'entries have been removed.', - 'The new configuration file has been saved to', dest) -tree.write(dest) diff --git a/misc/getmupdf.sh b/misc/getmupdf.sh deleted file mode 100644 index 29cb0ee..0000000 --- a/misc/getmupdf.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/sh -set -eu - -MUPDF_OUTPUT_DIR="$1" -u="git://git.ghostscript.com/mupdf" -#u="https://github.com/ArtifexSoftware/mupdf" -MUPDF_URL="${2-$u}" -MUPDF_DESIRED_VERSION="f6ddaf30da1defe3be961f1172b83554bc6f6b48" - -if [ ! -d ${MUPDF_OUTPUT_DIR} ]; then - echo "mupdf does not exist, fetching it from ${MUPDF_URL}" - git clone ${cloneargs-} ${MUPDF_URL} --recursive ${MUPDF_OUTPUT_DIR} -fi - -cd ${MUPDF_OUTPUT_DIR} -git remote update -MUPDF_VERSION=$(git rev-parse HEAD) - -test "${MUPDF_VERSION}" = "${MUPDF_DESIRED_VERSION}" || { - printf "mupdf current version is ${MUPDF_VERSION} " - echo "switching to ${MUPDF_DESIRED_VERSION}" - git reset --hard ${MUPDF_DESIRED_VERSION} - git submodule update --init --recursive -} diff --git a/misc/keys.txt b/misc/keys.txt deleted file mode 100644 index 70cf7d7..0000000 --- a/misc/keys.txt +++ /dev/null @@ -1,22 +0,0 @@ - - - - - - - - - - - - - - - - - diff --git a/misc/links.org b/misc/links.org deleted file mode 100644 index 4a880db..0000000 --- a/misc/links.org +++ /dev/null @@ -1,8 +0,0 @@ -* xclip https://github.com/astrand/xclip -* stardict http://www.huzheng.org/stardict/ -* rofi https://github.com/DaveDavenport/rofi -* prince https://www.princexml.com/ -* unoconv https://github.com/dagwieers/unoconv -* texi2html http://www.nongnu.org/texi2html/ -* ddjvu http://djvu.sourceforge.net/doc/man/ddjvu.html -* pandoc http://pandoc.org diff --git a/misc/llpp.inotify b/misc/llpp.inotify deleted file mode 100755 index 3b7e168..0000000 --- a/misc/llpp.inotify +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh -# This wrapper provides automatic reloading on file modifications -# to the pdfviewer llpp via inotify. - -# Prepare parameters. -cd "$(dirname "$1")" -pdf=$(basename "$1") -shift -passthrough="$@" - -# Return with an error if the given file does not exist. -if [ ! -e "$pdf" ]; then - echo "$pdf: No such file or directory" - exit 1 -fi - -# Start llpp with the given file. -llpp "$pdf" $passthrough & - -# Track the PID of the llpp instance. -pid_llpp=$! - -# Kill the llpp instance if the shell script terminates. -trap "kill ${pid_llpp}" SIGINT SIGTERM SIGQUIT SIGKILL - -# Watch for changes in the directory of the given file. This is necessary -# to recieve events after the file was deleted. -inotifywait -m -e close_write "$PWD" -q --format "%f"| while read file; do - # Only refresh on events of the file in question and if this file exists. - if [ "$file" = "$pdf" ] && [ -e "$pdf" ]; then - kill -HUP $pid_llpp - fi -done & - -# If llpp terminates kill the inotifywait process. -wait $pid_llpp -pkill -P $$ -cd - > /dev/null diff --git a/misc/llppac b/misc/llppac deleted file mode 100755 index 46dd727..0000000 --- a/misc/llppac +++ /dev/null @@ -1,171 +0,0 @@ -#!/bin/sh -set -eu - -die() { - echo "$1" >&2 - exit 1 -} - -cachedir="$HOME/.cache/llpp" -test -d "$cachedir" || die "cache directory '$cachedir' does not exist" - -caspsuf= -type= - -executable_p() { command -v "$1" >/dev/null 2>&1; } - -missing() { - executable_p $1 || \ - eval "$1() { die \"$2 is needed for \$type conversion\"; }" -} -trap 'test -n "${casp-}" && rm -f "$casp"' 0 - -while getopts s:c:m:t:fu opt; do - case $opt in - m) mime=$OPTARG;; - t) type=$OPTARG;; - f) force=true;; - c) css="-s $OPTARG";; - ?) die "usage: $0 [-c css] [-m mime/type] [-t filter] [-f] [path|url]";; - esac -done -shift $(($OPTIND - 1)) -test -z "$1" && die "usage $0: path" - -origin="$1" -if ${force-test ! -e "$1"} && expr >/dev/null "$1" : "\(ftp\|https\?\)://"; -then - if executable_p wget; then - dl() { wget -q $1 -O $2; } - elif executable_p curl; then - dl() { curl -L $1 -o $2; } - else - die "no program to fetch remote urls found" - fi - - hashof="$cachedir/$(basename "$1")" - dl "$1" "$hashof" || test -e "$md5of" - shift - set -- "$hashof" "$@" -else - hashof="$1" -fi - -test -z "$type" && { - ft=$(file -L --mime-type -b "$1") || die "$ft"; - - case $ft in - application/x-gzip | application/x-compress) dc=zcat;; - application/x-xz) dc=xzcat;; - application/x-bzip2) dc=bzcat;; - *) unset dc || true;; - esac -} - -filt='"${dc-cat}" "$1" |' - -typeofmime() { - case "$1" in - application/postscript) type=ps;; - application/pdf) type=pdf;; - image/vnd.djvu) type=djvu;; - text/html) type=html;; - text/plain) type=text;; - application/msword) type=word;; - application/vnd.openxmlformats-officedocument.* \ - | application/vnd.ms-powerpoint \ - | application/vnd.ms-excel \ - | application/vnd.oasis.opendocument.*) type=uno;; - image/svg+xml) type=svg;; - image/png | image/jpeg) - test -n "${dc-}" && type="image" || type="image2";; - image/*) type=image;; - application/x-dvi) type=dvi;; - *) return 1;; - esac - return 0 -} - -if test -z "$type"; then - test -z "${mime-}" && \ - mime=$(file -L --mime-type -b "$1" || die "$mime") || \ - $(file -L --mime-type -bz "$1" || die "$mime") - typeofmime "$mime" || die "unhandled file type: '$mime'" -fi - -caspsuf=".pdf" -case $type in - ps) - missing ps2pdf "ps2df(https://ghostscript.com/)" - conv='ps2pdf - "$casp"' - ;; - image2|pdf) test -z "${dc-}" && exec llpp "$@" || conv='cat >"$casp"';; - texi) - missing texi2html "texi2html(http://www.nongnu.org/texi2html/)" - conv='texi2html - -o $casp' - caspsuf=.html - ;; - djvu) - missing ddjvu "ddjvu(http://djvu.sourceforge.net/doc/man/ddjvu.html)" - conv='ddjvu -format=pdf - "$casp"' - ;; - html) - missing prince "Prince(http://www.princexml.com/)" - conv='prince $css - -o "$casp"' - ;; - html2epub) - missing pandoc "pandoc(http://pandoc.org)" - caspsuf=".epub" - conv='pandoc -r html - -w epub2 -o "$casp"' - ;; - word) - missing unoconv "unoconv" - filt= - conv='unoconv -o "$casp" "$1"' - ;; - uno) - test -n "$dc" && die "cannot convert compressed '$mime'" - unset filt - missing unoconv "unoconv(http://dag.wiee.rs/home-made/unoconv/)" - conv='unoconv -o "$casp" "$1"' - ;; - svg) - if executable_p inkscape && test -z "$dc"; then - unset filt - conv='inkscape -z -A "$casp" "$1"' - else - if executable_p rsvg-convert; then - conv='rsvg-convert -f pdf -o "$casp"' - else - test -n "$dc" && die "cannot convert compressed '$mime'" - unset filt - missing unoconv "unoconv(http://dag.wiee.rs/home-made/unoconv/)" - conv='unoconv -o "$casp" "$1"' - fi - fi - ;; - image) - missing convert "convert(http://www.imagemagick.org/script/convert.php)" - conv='convert - pdf:"$casp"' - ;; - dvi) - test -n "$dc" && die "cannot convert compressed '$mime'" - unset filt - missing dvipdf "dvipdf(http://ghostscript.com/)" - conv='dvipdf "$1" "$casp"' - ;; - text) - missing pandoc "pandoc(http://pandoc.org/)" - conv='pandoc -t epub2 - -o "$casp"' - caspsuf=.epub - ;; - *) die "unhandled filter type: '$type'";; -esac - -hash=$(cksum "$hashof") || die "$hash" -casp=$cachedir/${hash%% *}$caspsuf - -{ test -n "${force-}" || test ! -e "$casp"; } && eval "$filt" "$conv" -shift - -exec llpp -origin $origin "$@" "$casp" diff --git a/misc/notes/mupdfref.txt b/misc/notes/mupdfref.txt deleted file mode 100644 index 4641faa..0000000 --- a/misc/notes/mupdfref.txt +++ /dev/null @@ -1,6 +0,0 @@ -mupdf git repository is enormous. mostly due to submodules and -attempts to use shallow clones of those were unsuccessful, so if one -has an existing mupdf checkout bandwidth can be saved by doing a clone -with a reference like so: - -$ cloneargs="--reference-if-able _/git/mupdf' sh misc/getmupdf.sh build/mupdf diff --git a/misc/notes/pzoom.txt b/misc/notes/pzoom.txt deleted file mode 100644 index ba10992..0000000 --- a/misc/notes/pzoom.txt +++ /dev/null @@ -1,22 +0,0 @@ -https://github.com/moosotc/llpp/issues/75 - -Looks like it's possible to make "progressive zoom" "nicer" by taking -already rendered tiles from the cache and scale them via GL in place -of not-yet-fully-rendered(by mupdf) ones, thus avoiding place holders -and providing more visually pleasant experience. - -There was some proof of concept code to do that, but the -implementation got lost, then build system took precedence, and -finally - "writers block". - -As a first step following algorithm should work: - - If tile isn't ready find all suitable tiles (same color-space etc etc) - and if "scaled" version has non-empty intersection with a tile that - is missing draw (scaled by GL version of) that instead. - - This, in my mind, potentially implies quite a bit of overdraw, - simplest solution appears to be to just use the dimensional - "closeness" as a Z value and enable and use depth testing when - rendering the cached and scaled tiles during this pass (instead of - some form of "painters algorithm" or something more elaborate) diff --git a/parser.ml b/parser.ml deleted file mode 100644 index 87fbbf4..0000000 --- a/parser.ml +++ /dev/null @@ -1,326 +0,0 @@ -(* based on Tor Andersson's XML parser from MuPDF's XPS module *) - -let iswhite = function - | '\r' | '\n' | '\t' | ' ' -> true - | _ -> false - -let isname = function - | '.' | '-' | '_' | ':' -> true - | c -> (c >= '0' && c <= '9') - || (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - -exception Parse_error of string * string * int - -let parse_error msg s pos = raise (Parse_error (msg, s, pos)) - -let enent s pos len = - let b = Buffer.create len in - let rec loop i = - if i - pos = len - then Buffer.contents b - else ( - begin match s.[i] with - | '<' -> Buffer.add_string b "<" - | '>' -> Buffer.add_string b ">" - | '\'' -> Buffer.add_string b "'" - | '\"' -> Buffer.add_string b """ - | '&' -> Buffer.add_string b "&" - | c -> - let code = Char.code c in - if code < 32 || code > 127 - then ( - Buffer.add_string b "&#"; - Buffer.add_string b (string_of_int code); - Buffer.add_char b ';'; - ) - else Buffer.add_char b c - end; - loop (i+1) - ) - in - loop pos - -let unent b s pos len = - let rec loop i = - if i != pos + len - then - let amppos = - try - String.index_from s i '&' - with Not_found -> -1 - in - if amppos = -1 || amppos >= pos + len - then Buffer.add_substring b s i (pos + len - i) - else ( - Buffer.add_substring b s i (amppos - i); - if amppos = i + len then Utils.error "lonely amp"; - - let semipos = - try - let semipos = String.index_from s (amppos+1) ';' in - if semipos >= pos + len then raise Not_found; - semipos - with Not_found -> - Utils.error "amp not followed by semicolon at %d" amppos - in - - let subslen = semipos-amppos-1 in - if subslen = 0 then Utils.error "empty amp at %d" amppos; - - let subs = String.sub s (amppos+1) subslen in - - if subs.[0] = '#' - then ( - if subslen = 1 - then Utils.error "empty amp followed by hash at %d" amppos; - let code = - if subs.[1] = 'x' - then Scanf.sscanf subs "#x%x" (fun n -> n) - else int_of_string (String.sub subs 1 (subslen-1)) - in - let c = Char.unsafe_chr code in - Buffer.add_char b c - ) - else ( - match subs with - | "lt" -> Buffer.add_char b '<' - | "gt" -> Buffer.add_char b '>' - | "amp" -> Buffer.add_char b '&' - | "apos" -> Buffer.add_char b '\'' - | "quot" -> Buffer.add_char b '\"' - | _ -> Utils.error "unknown amp %S" subs - ); - loop (semipos+1) - ) - in - loop pos - -let subs s pos = - let len = String.length s in - let left = len - pos in - if left < 0 - then Printf.sprintf "(pos=%d len=%d left=%d)" pos len left - else - let len = min left 10 in - String.sub s pos len - -let ts = function - | `text -> "text" - | `lt -> "lt" - | `close -> "close" - | `exclam -> "exclam" - | `question -> "question" - | `doctype -> "doctype" - | `comment -> "comment" - | `tag -> "tag" - -type attr = string * string - and attrs = attr list - and vp = - | Vdata - | Vcdata - | Vopen of string * attrs * bool - | Vclose of string - | Vend - and 'a v = { f : 'a v -> vp -> int -> int -> 'a v; accu : 'a } - -let parse v s = - let r_comment_terminator = Str.regexp "-->" - and r_CDATA_terminator = Str.regexp "\\]\\]>" - and r_q_terminator = Str.regexp "\\?>" in - - let slen = String.length s in - - let find_substr pos subs r = - let pos = - try - Str.search_forward r s pos - with Not_found -> - parse_error ("cannot find substring " ^ subs) s pos - in - pos - in - let begins_with pos prefix = Utils.substratis s pos prefix in - let find_non_white pos = - let rec forward i = - if i >= slen - then parse_error "cannot find non white space character" s pos; - if iswhite s.[i] then forward (i+1) else i in - forward pos - in - - let getname pos = - let non_name_pos = - let rec find_non_name i = - if i >= slen then parse_error "cannot find non name character" s pos; - if isname s.[i] then find_non_name (i+1) else i - in - find_non_name pos - in - non_name_pos, String.sub s pos (non_name_pos - pos) - in - - let rec collect v pos t = - if pos >= slen && t != `text - then parse_error ("not enough data for " ^ ts t) s pos; - - match t with - | `text -> - let ltpos = - try - String.index_from s pos '<' - with Not_found -> - let rec trailsbywhite i = - if pos+i = String.length s - then -1 - else ( - if not (iswhite s.[pos+i]) - then parse_error "garbage at the end" s pos - else trailsbywhite (i+1) - ) - in - trailsbywhite 0 - in - if ltpos = -1 - then v.f v Vend pos slen, slen - else - let start_of_text_pos = find_non_white pos in - let end_of_text_pos = - if start_of_text_pos < ltpos - then - let rec find i = - if i = start_of_text_pos || not (iswhite s.[i]) - then i+1 - else find (i-1) - in - find (ltpos-1) - else start_of_text_pos - in - let v = - if start_of_text_pos != end_of_text_pos - then v.f v Vdata start_of_text_pos end_of_text_pos - else v - in - collect v (ltpos+1) `lt - - | `lt -> - let pos, t = - match s.[pos] with - | '/' -> (pos+1), `close - | '!' -> (pos+1), `exclam - | '?' -> (pos+1), `question - | c when isname c -> pos, `tag - | _ -> parse_error "invalid data after <" s pos - in - collect v pos t - - | `close -> - let tag_name_pos = find_non_white pos in - let tag_name_end_pos, close_tag_name = getname tag_name_pos in - let close_tag_pos = find_non_white tag_name_end_pos in - if s.[close_tag_pos] != '>' - then parse_error "missing >" s pos; - let pos' = close_tag_pos + 1 in - let v = v.f v (Vclose close_tag_name) pos pos' in - collect v pos' `text - - | `doctype -> - let close_tag_pos = - try - String.index_from s pos '>' - with Not_found -> - parse_error "doctype is not terminated" s pos - in - collect v (close_tag_pos+1) `text - - | `comment -> - let pos = - try - find_substr pos "-->" r_comment_terminator - with Not_found -> - parse_error "comment is not terminated" s pos - in - collect v (pos+3) `text - - | `exclam -> - if begins_with pos "[CDATA[" - then - let cdata_start = pos+7 in - let cdata_end = find_substr cdata_start "]]>" r_CDATA_terminator in - let v = v.f v Vcdata cdata_start cdata_end in - collect v (cdata_end+3) `text - else ( - if begins_with pos "DOCTYPE" - then - collect v (pos+7) `doctype - else ( - if begins_with pos "--" - then collect v (pos+2) `comment - else parse_error "unknown shit after exclamation mark" s pos - ) - ) - - | `question -> - let pos = find_substr pos "?>" r_q_terminator in - collect v (pos+2) `text - - | `tag -> - let pos', name = getname pos in - let attrs, pos', closed = collect_attributes pos' in - let v = v.f v (Vopen (name, attrs, closed)) pos pos' in - collect v pos' `text - - and collect_attributes pos = - let rec f accu pos = - let nameval pos = - let pos, name = getname pos in - let pos = find_non_white pos in - if s.[pos] = '=' - then - let qpos = pos+1 in - if qpos = slen - then parse_error "not enough data for attribute" s pos; - - let qc = s.[qpos] in - if not (qc = '\'' || qc = '\"') - then parse_error "assignment is not followed by a quote" s pos; - - let closing_q_pos = - let rec find i = - if i = slen - then parse_error "not enough data for attribute value" s pos; - - if s.[i] = qc then i else find (i+1) - in - find (qpos+1) - in - - let vallen = closing_q_pos - (qpos+1) in - let val' = String.sub s (qpos+1) vallen in - (name, val'), closing_q_pos+1 - - else parse_error "attribute name not followed by '='" s pos - in - - let pos = find_non_white pos in - if s.[pos] = '>' - then accu, pos+1, false - else ( - if slen - pos > 2 && s.[pos] = '/' && s.[pos+1] = '>' - then accu, pos+2, true - else ( - if isname s.[pos] - then ( - let nameval, pos = nameval pos in - let accu = nameval :: accu in - f accu pos - ) - else parse_error "malformed attribute list" s pos; - ) - ) - in - f [] pos - in - let _, _ = collect v 0 `text in - v.accu diff --git a/parser.mli b/parser.mli deleted file mode 100644 index a309a10..0000000 --- a/parser.mli +++ /dev/null @@ -1,18 +0,0 @@ -exception Parse_error of string * string * int -val parse_error : string -> string -> int -> 'a -val enent : string -> int -> int -> string -val unent : Buffer.t -> string -> int -> int -> unit -val subs : string -> int -> string -val ts : - [< `close | `comment | `doctype | `exclam | `lt | `question | `tag | `text - ] -> string -type attr = string * string -and attrs = attr list -and vp = - Vdata - | Vcdata - | Vopen of string * attrs * bool - | Vclose of string - | Vend -and 'a v = { f : 'a v -> vp -> int -> int -> 'a v; accu : 'a; } -val parse : 'a v -> string -> 'a diff --git a/todo.org b/todo.org deleted file mode 100644 index 9968a8e..0000000 --- a/todo.org +++ /dev/null @@ -1,47 +0,0 @@ -* TODO progressive zoom -* TODO Fixme -** linknav + presentation (link might not fit the visible area) -* TODO outline for cbz - file names? exif? -* TODO build.bash -** Parallel builds - gmk=1 bash build bash build - generates Makefile for "gmake -jN" - it maybe possible to utilize GNU parallel(1) inside build.bash to - achieve the same without GNU make -* TODO [maybe] inside rect/quad (_Generic) -* TODO threaded rendering -* TODO wikit - https://github.com/moosotc/llpp/issues/128 -* TODO (maybe?) make C replies use byte commands too -* TODO reset fractional coordinates when needed -* TODO kymap mapcode - add a way to bind keycodes (not keysyms) to actions -* TODO multiple targets in build.bash - exit inside 'doc' target is not, in general, correct -* TODO scroll by paragraph/block - - State "TODO" from [2021-12-06 Mon 23:35] -* TODO judicious use of memchanged -* TODO fix multicolumn visible eviction K330w-manual.pdf - - State "TODO" from [2021-12-07 Tue 00:49] - -7 columns - - - - zoom pan quit, load - position is not the same - -* TODO llpp -last and llpp select first entry in history behave differently - 586cb865549a22765a91ee0983e02a56429b1577 -* TODO llpp recode and comment "tile" handling diff --git a/uiutils.ml b/uiutils.ml deleted file mode 100644 index 811d01b..0000000 --- a/uiutils.ml +++ /dev/null @@ -1,796 +0,0 @@ -open Utils -open Glutils -open Config - -let scrollph y maxy = - let sh = float (maxy + !S.winh) /. float !S.winh in - let sh = float !S.winh /. sh in - let sh = max sh (float conf.scrollh) in - - let percent = float y /. float maxy in - let position = (float !S.winh -. sh) *. percent in - - let position = - if position +. sh > float !S.winh - then float !S.winh -. sh - else position - in - position, sh - -let isbirdseye = function - | Birdseye _ -> true - | Textentry _ | View | LinkNav _ -> false - -let istextentry = function - | Textentry _ -> true - | Birdseye _ | View | LinkNav _ -> false - -let vscrollw () = - if !S.uioh#alwaysscrolly || ((conf.scrollb land scrollbvv != 0) - && (!S.maxy > !S.winh)) - then conf.scrollbw - else 0 - -let vscrollhit x = - if conf.leftscroll - then x < vscrollw () - else x > !S.winw - vscrollw () - -let firstof first active = - if first > active || abs (first - active) > fstate.maxrows - 1 - then max 0 (active - (fstate.maxrows/2)) - else first - -let calcfirst first active = - if active > first - then - let rows = active - first in - if rows > fstate.maxrows then active - fstate.maxrows else first - else active - -let enttext () = - let len = String.length !S.text in - let x0 = if conf.leftscroll then vscrollw () else 0 in - let drawstring s = - let hscrollh = - match !S.mode with - | Textentry _ | View | LinkNav _ -> - let h, _, _ = !S.uioh#scrollpw in - h - | Birdseye _ -> 0 - in - let rect x w = - filledrect - x (float (!S.winh - (fstate.fontsize + 4) - hscrollh)) - (x+.w) (float (!S.winh - hscrollh)) - in - - let w = float (!S.winw - 1 - vscrollw ()) in - if !S.progress >= 0.0 && !S.progress < 1.0 - then ( - GlDraw.color (0.3, 0.3, 0.3); - let w1 = w *. !S.progress in - rect (float x0) w1; - GlDraw.color (0.0, 0.0, 0.0); - rect (float x0+.w1) (float x0+.w-.w1) - ) - else ( - GlDraw.color (0.0, 0.0, 0.0); - rect (float x0) w; - ); - - GlDraw.color (1.0, 1.0, 1.0); - drawstring - fstate.fontsize - (if conf.leftscroll then x0 + 2 else x0 + if len > 0 then 8 else 2) - (!S.winh - hscrollh - 5) s; - in - let s = - match !S.mode with - | Textentry ((prefix, text, _, _, _, _), _) -> - let s = - if len > 0 - then Printf.sprintf "%s%s_ [%s]" prefix text !S.text - else Printf.sprintf "%s%s_" prefix text - in - s - - | Birdseye _ | View | LinkNav _ -> !S.text - in - let s = - if !S.newerrmsgs - then ( - if not (istextentry !S.mode) && !S.uioh#eformsgs - then - let s1 = "(press 'e' to review error messages)" in - if nonemptystr s then s ^ " " ^ s1 else s1 - else s - ) - else s - in - if nonemptystr s - then drawstring s - -let textentrykeyboard - key mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) = - S.text := E.s; - let enttext te = - S.mode := Textentry (te, onleave); - enttext (); - postRedisplay "textentrykeyboard enttext"; - in - let histaction cmd = - match opthist with - | None -> () - | Some (action, _) -> - let te = (c, action cmd, opthist, onkey, ondone, cancelonempty) in - S.mode := Textentry (te, onleave); - postRedisplay "textentry histaction" - in - let open Keys in - let kt = Wsi.ks2kt key in - match [@warning "-fragile-match"] kt with - | Backspace -> - if emptystr text && cancelonempty - then ( - onleave Cancel; - postRedisplay "textentrykeyboard after cancel"; - ) - else - let s = withoutlastutf8 text in - enttext (c, s, opthist, onkey, ondone, cancelonempty) - - | Enter -> - ondone text; - onleave Confirm; - postRedisplay "textentrykeyboard after confirm" - - | Up -> histaction HCprev - | Down -> histaction HCnext - | Home -> histaction HCfirst - | End -> histaction HClast - - | Escape -> - if emptystr text - then ( - begin match opthist with - | None -> () - | Some (_, onhistcancel) -> onhistcancel () - end; - onleave Cancel; - S.text := E.s; - postRedisplay "textentrykeyboard after cancel2" - ) - else enttext (c, E.s, opthist, onkey, ondone, cancelonempty) - - | Delete -> () - - | Insert when Wsi.withshift mask -> - let s = getcmdoutput (fun s -> - prerr_endline ("error pasting: " ^ s)) conf.pastecmd in - enttext (c, s, opthist, onkey, ondone, cancelonempty) - - | Code _ | Ascii _ -> - begin match onkey text kt with - | TEdone text -> - ondone text; - onleave Confirm; - postRedisplay "textentrykeyboard after confirm2"; - - | TEcont text -> enttext (c, text, opthist, onkey, ondone, cancelonempty); - - | TEstop -> - onleave Cancel; - postRedisplay "textentrykeyboard after cancel3"; - - | TEswitch te -> - S.mode := Textentry (te, onleave); - postRedisplay "textentrykeyboard switch"; - end - | _ -> vlog "unhandled key" - -class type lvsource = - object - method getitemcount : int - method getitem : int -> (string * int) - method hasaction : int -> bool - method exit : uioh:uioh -> - cancel:bool -> - active:int -> - first:int -> - pan:int -> - uioh option - method getactive : int - method getfirst : int - method getpan : int - method getminfo : (int * int) array - end - -class virtual lvsourcebase = - object - val mutable m_active = 0 - val mutable m_first = 0 - val mutable m_pan = 0 - method getactive = m_active - method getfirst = m_first - method getpan = m_pan - method getminfo : (int * int) array = E.a - end - -let coe s = (s :> uioh) -let setuioh uioh = S.uioh := coe uioh - -let changetitle uioh = - let title = uioh#title in - Wsi.settitle @@ if emptystr title then "llpp" else title ^ " - llpp"; - -class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash = -object (self) - val m_pan = source#getpan - val m_first = source#getfirst - val m_active = source#getactive - val m_qsearch = E.s - val m_prev_uioh = !S.uioh - - method private elemunder y = - if y < 0 - then None - else - let n = y / (fstate.fontsize+1) in - if m_first + n < source#getitemcount - then ( - if source#hasaction (m_first + n) - then Some (m_first + n) - else None - ) - else None - - method display = - Gl.enable `blend; - GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha; - GlDraw.color (0., 0., 0.) ~alpha:0.85; - filledrect 0. 0. (float !S.winw) (float !S.winh); - GlDraw.color (1., 1., 1.); - Gl.enable `texture_2d; - let fs = fstate.fontsize in - let nfs = fs + 1 in - let hw = !S.winw/3 in - let ww = fstate.wwidth in - let tabw = 17.0*.ww in - let itemcount = source#getitemcount in - let minfo = source#getminfo in - if conf.leftscroll - then ( - GlMat.push (); - GlMat.translate ~x:(float conf.scrollbw) (); - ); - let x0 = 0.0 and x1 = float (!S.winw - conf.scrollbw - 1) in - let rec loop row = - if not ((row - m_first) > fstate.maxrows) - then ( - if row >= 0 && row < itemcount - then ( - let (s, level) = source#getitem row in - let y = (row - m_first) * nfs in - let x = 5.0 +. (float (level + m_pan)) *. ww in - if helpmode - then GlDraw.color - (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c)); - - if row = m_active - then ( - Gl.disable `texture_2d; - let alpha = if source#hasaction row then 0.9 else 0.3 in - GlDraw.color (1., 1., 1.) ~alpha; - linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3)); - Gl.enable `texture_2d; - ); - let c = - if zebra && row land 1 = 1 - then 0.8 - else 1.0 - in - GlDraw.color (c,c,c); - let drawtabularstring s = - let drawstr x s = - let x' = truncate (x0 +. x) in - let s1, s2 = splitatchar s '\000' in - if emptystr s2 - then Ffi.drawstr fs x' (y+nfs) s - else - let rec e s = - if emptystr s - then s - else - let s' = withoutlastutf8 s in - let s = s' ^ Utf8syms.ellipsis in - let w = Ffi.measurestr fs s in - if float x' +. w +. ww < float (hw + x') - then s - else e s' - in - let s1 = - if float x' +. ww +. Ffi.measurestr fs s1 > float (hw + x') - then e s1 - else s1 - in - ignore (Ffi.drawstr fs x' (y+nfs) s1); - Ffi.drawstr fs (hw + x') (y+nfs) s2 - in - if trusted - then - let x = if helpmode && row > 0 then x +. ww else x in - let s1, s2 = splitatchar s '\t' in - if nonemptystr s2 - then - let nx = drawstr x s1 in - let sw = nx -. x in - let x = x +. (max tabw sw) in - drawstr x s2 - else - let len = String.length s - 2 in - if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7' - then - let s = String.sub s 2 len in - let x = if not helpmode then x +. ww else x in - GlDraw.color (1.2, 1.2, 1.2); - let vinc = Ffi.drawstr (fs+fs/4) - (truncate (x -. ww)) (y+nfs) s in - GlDraw.color (1., 1., 1.); - vinc +. (float fs *. 0.8) - else drawstr x s - else drawstr x s - in - ignore (drawtabularstring s); - loop (row+1) - ) - ) - in - loop m_first; - GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5; - let xadj = 5.0 in - let rec loop row = - if (row - m_first) <= fstate.maxrows - then - if row >= 0 && row < itemcount - then - let (s, level) = source#getitem row in - let pos0 = Ne.index s '\000' in - let y = (row - m_first) * nfs in - let x = float (level + m_pan) *. ww in - let (first, last) = minfo.(row) in - let prefix = - if pos0 > 0 && first > pos0 - then String.sub s (pos0+1) (first-pos0-1) - else String.sub s 0 first - in - let suffix = String.sub s first (last - first) in - let w1 = Ffi.measurestr fstate.fontsize prefix in - let w2 = Ffi.measurestr fstate.fontsize suffix in - let x = x +. if conf.leftscroll then xadj else 5.0 in - let x = if pos0 > 0 && first > pos0 then x +. float hw else x in - let x0 = x +. w1 - and y0 = float (y+2) in - let x1 = x0 +. w2 - and y1 = float (y+fs+3) in - filledrect x0 y0 x1 y1; - loop (row+1) - in - Gl.disable `texture_2d; - if Array.length minfo > 0 then loop m_first; - Gl.disable `blend; - if conf.leftscroll - then GlMat.pop () - - method nextcurlevel incr = - let len = source#getitemcount in - let curlevel = - if m_active >= 0 && m_active < len - then snd (source#getitem m_active) - else -1 - in - let rec flow i = - if i = len - then i-1 - else ( - if i < 0 - then 0 - else - let _, l = source#getitem i in - if l <= curlevel then i else flow (i+incr) - ) - in - let active = flow (m_active+incr) in - let first = calcfirst m_first active in - postRedisplay "listview nextcurlevel"; - {< m_active = active; m_first = first >} - - method updownlevel incr = - let len = source#getitemcount in - let curlevel = - if m_active >= 0 && m_active < len - then snd (source#getitem m_active) - else -1 - in - let rec flow i = - if i = len - then i-1 - else ( - if i = -1 then 0 else - let _, l = source#getitem i in - if l != curlevel then i else flow (i+incr) - ) - in - let active = flow m_active in - let first = calcfirst m_first active in - postRedisplay "listview updownlevel"; - {< m_active = active; m_first = first >} - - method private key1 key mask = - let set1 active first qsearch = - coe {< m_active = active; m_first = first; m_qsearch = qsearch >} - in - let search active pattern incr = - let active = if active = -1 then m_first else active in - let dosearch re = - let rec loop n = - if n >= 0 && n < source#getitemcount - then ( - let s, _ = source#getitem n in - match Str.search_forward re s 0 with - | exception Not_found -> loop (n + incr) - | _ -> Some n - ) - else None - in - loop active - in - let qpat = Str.quote pattern in - match Str.regexp_case_fold qpat with - | s -> dosearch s - | exception exn -> - dolog "regexp_case_fold for `%S' failed: %S\n" qpat @@ - Printexc.to_string exn; - None - in - let itemcount = source#getitemcount in - let find start incr = - let rec find i = - if i = -1 || i = itemcount - then -1 - else ( - if source#hasaction i - then i - else find (i + incr) - ) - in - find start - in - let set active first = - let first = bound first 0 (itemcount - fstate.maxrows) in - S.text := E.s; - coe {< m_active = active; m_first = first; m_qsearch = E.s >} - in - let navigate incr = - let isvisible first n = n >= first && n - first <= fstate.maxrows in - let active, first = - let incr1 = if incr > 0 then 1 else -1 in - if isvisible m_first m_active - then - let next = - let next = m_active + incr in - let next = - if next < 0 || next >= itemcount - then -1 - else find next incr1 - in - if abs (m_active - next) > fstate.maxrows - then -1 - else next - in - if next = -1 - then - let first = m_first + incr in - let first = bound first 0 (itemcount - fstate.maxrows) in - let next = - let next = m_active + incr in - let next = bound next 0 (itemcount - 1) in - find next ~-incr1 - in - let active = - if next = -1 - then m_active - else ( - if isvisible first next - then next - else m_active - ) - in - active, first - else - let first = min next m_first in - let first = - if abs (next - first) > fstate.maxrows - then first + incr - else first - in - next, first - else - let first = m_first + incr in - let first = bound first 0 (itemcount - 1) in - let active = - let next = m_active + incr in - let next = bound next 0 (itemcount - 1) in - let next = find next incr1 in - let active = - if next = -1 || abs (m_active - first) > fstate.maxrows - then ( - let active = if m_active = -1 then next else m_active in - active - ) - else next - in - if isvisible first active - then active - else -1 - in - active, first - in - postRedisplay "listview navigate"; - set active first; - in - let open Keys in - let kt = Wsi.ks2kt key in - match [@warning "-fragile-match"] kt with - | Ascii (('r'|'s') as c) when Wsi.withctrl mask -> - let incr = if c = 'r' then -1 else 1 in - let active, first = - match search (m_active + incr) m_qsearch incr with - | None -> - S.text := m_qsearch ^ " [not found]"; - m_active, m_first - | Some active -> - S.text := m_qsearch; - active, firstof m_first active - in - postRedisplay "listview ctrl-r/s"; - set1 active first m_qsearch; - - | Insert when Wsi.withctrl mask -> - if m_active >= 0 && m_active < source#getitemcount - then ( - let s, _ = source#getitem m_active in - selstring conf.selcmd s; - ); - coe self - - | Backspace -> - if emptystr m_qsearch - then coe self - else ( - let qsearch = withoutlastutf8 m_qsearch in - if emptystr qsearch - then ( - S.text := E.s; - postRedisplay "listview empty qsearch"; - set1 m_active m_first E.s; - ) - else - let active, first = - match search m_active qsearch ~-1 with - | None -> - S.text := qsearch ^ " [not found]"; - m_active, m_first - | Some active -> - S.text := qsearch; - active, firstof m_first active - in - postRedisplay "listview backspace qsearch"; - set1 active first qsearch - ); - - | Ascii _ | Code _ -> - let utf8 = - match [@warning "-partial-match"] kt with - | Ascii c -> String.make 1 c - | Code code -> Ffi.toutf8 code - in - let pattern = m_qsearch ^ utf8 in - let active, first = - match search m_active pattern 1 with - | None -> - S.text := pattern ^ " [not found]"; - m_active, m_first - | Some active -> - S.text := pattern; - active, firstof m_first active - in - postRedisplay "listview qsearch add"; - set1 active first pattern; - - | Escape -> - S.text := E.s; - if emptystr m_qsearch - then ( - postRedisplay "list view escape"; - (* XXX: - let mx, my = state.mpos in - updateunder mx my; - *) - Option.value ~default:m_prev_uioh @@ - source#exit ~uioh:(coe self) ~cancel:true ~active:m_active - ~first:m_first ~pan:m_pan - ) - else ( - postRedisplay "list view kill qsearch"; - coe {< m_qsearch = E.s >} - ) - - | Enter -> - S.text := E.s; - let self = {< m_qsearch = E.s >} in - let opt = - postRedisplay "listview enter"; - let cancel = not (m_active >= 0 && m_active < source#getitemcount) in - source#exit ~uioh:(coe self) ~cancel - ~active:m_active ~first:m_first ~pan:m_pan; - in - Option.value ~default:m_prev_uioh opt - - | Delete -> coe self - | Up -> navigate ~-1 - | Down -> navigate 1 - | Prior -> navigate ~-(fstate.maxrows) - | Next -> navigate fstate.maxrows - - | Right -> - S.text := E.s; - postRedisplay "listview right"; - coe {< m_pan = m_pan - 1 >} - - | Left -> - S.text := E.s; - postRedisplay "listview left"; - coe {< m_pan = m_pan + 1 >} - - | Home -> - let active = find 0 1 in - postRedisplay "listview home"; - set active 0; - - | End -> - let first = max 0 (itemcount - fstate.maxrows) in - let active = find (itemcount - 1) ~-1 in - postRedisplay "listview end"; - set active first; - - | _ -> coe self - - method key key mask = - match !S.mode with - | Textentry te -> - textentrykeyboard key mask te; - coe self - | Birdseye _ | View | LinkNav _ -> self#key1 key mask - - method button button down x y _ = - let opt = - match button with - | 1 when vscrollhit x -> - postRedisplay "listview scroll"; - if down - then - let _, position, sh = self#scrollph in - if y > truncate position && y < truncate (position +. sh) - then ( - S.mstate := Mscrolly; - Some (coe self) - ) - else - let s = float (max 0 (y - conf.scrollh)) /. float !S.winh in - let first = truncate (s *. float source#getitemcount) in - let first = min source#getitemcount first in - Some (coe {< m_first = first; m_active = first >}) - else ( - S.mstate := Mnone; - Some (coe self); - ); - | 1 when down -> - begin match self#elemunder y with - | Some n -> - postRedisplay "listview click"; - source#exit ~uioh:(coe {< m_active = n >}) - ~cancel:false ~active:n ~first:m_first ~pan:m_pan - | _ -> Some (coe self) - end - | n when (n == 4 || n == 5) && not down -> - let len = source#getitemcount in - let first = - if n = 5 && m_first + fstate.maxrows >= len - then m_first - else - let first = m_first + (if n == 4 then -1 else 1) in - bound first 0 (len - 1) - in - postRedisplay "listview wheel"; - Some (coe {< m_first = first >}) - | n when (n = 6 || n = 7) && not down -> - let inc = if n = 7 then -1 else 1 in - postRedisplay "listview hwheel"; - Some (coe {< m_pan = m_pan + inc >}) - | _ -> Some (coe self) - in - Option.value ~default:m_prev_uioh opt - - method multiclick _ x y = self#button 1 true x y - - method motion _ y = - match !S.mstate with - | Mscrolly -> - let s = float (max 0 (y - conf.scrollh)) /. float !S.winh in - let first = truncate (s *. float source#getitemcount) in - let first = min source#getitemcount first in - postRedisplay "listview motion"; - coe {< m_first = first; m_active = first >} - | Msel _ - | Mpan _ - | Mscrollx - | Mzoom _ - | Mzoomrect _ - | Mnone -> coe self - - method pmotion x y = - if x < !S.winw - conf.scrollbw - then - let n = - match self#elemunder y with - | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active - | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n - in - let o = - if n != m_active - then (postRedisplay "listview pmotion"; {< m_active = n >}) - else self - in - coe o - else ( - Wsi.setcursor Wsi.CURSOR_INHERIT; - coe self - ) - - method infochanged _ = () - - method scrollpw = (0, 0.0, 0.0) - method scrollph = - let nfs = fstate.fontsize + 1 in - let y = m_first * nfs in - let itemcount = source#getitemcount in - let maxi = max 0 (itemcount - fstate.maxrows) in - let maxy = maxi * nfs in - let p, h = scrollph y maxy in - conf.scrollbw, p, h - - method modehash = modehash - method eformsgs = false - method alwaysscrolly = true - method scroll _ dy = - let self = - if dy != 0 - then ( - let len = source#getitemcount in - let first = - if dy > 0 && m_first + fstate.maxrows >= len - then m_first - else - let first = m_first + dy / 10 in - bound first 0 (len - 1) - in - postRedisplay "listview wheel"; - {< m_first = first >} - ) - else self - in - coe self - - method zoom _ _ _ = () -end diff --git a/uiutils.mli b/uiutils.mli deleted file mode 100644 index 5cde4ad..0000000 --- a/uiutils.mli +++ /dev/null @@ -1,88 +0,0 @@ -val scrollph : int -> int -> float * float -val isbirdseye : Config.mode -> bool -val istextentry : Config.mode -> bool -val vscrollw : unit -> int -val vscrollhit : int -> bool -val firstof : int -> int -> int -val calcfirst : int -> int -> int -val enttext : unit -> unit -val textentrykeyboard : int -> int -> - (string * string * Config.onhist option * Config.onkey * Config.ondone * - Config.cancelonempty) * Config.onleave -> unit -class type lvsource = - object - method exit : - uioh:Config.uioh -> - cancel:bool -> active:int -> first:int -> pan:int -> Config.uioh option - method getactive : int - method getfirst : int - method getitem : int -> string * int - method getitemcount : int - method getminfo : (int * int) array - method getpan : int - method hasaction : int -> bool - end -class virtual lvsourcebase : - object - val mutable m_active : int - val mutable m_first : int - val mutable m_pan : int - method getactive : int - method getfirst : int - method getminfo : (int * int) array - method getpan : int - end -val changetitle : < title : string; .. > -> unit -class listview : - zebra:bool -> - helpmode:bool -> - source:lvsource -> - trusted:bool -> - modehash:Config.keyhash -> - object ('a) - val m_active : int - val m_first : int - val m_pan : int - val m_prev_uioh : Config.uioh - val m_qsearch : string - method alwaysscrolly : bool - method button : int -> bool -> int -> int -> int -> Config.uioh - method display : unit - method eformsgs : bool - method private elemunder : int -> int option - method infochanged : Config.infochange -> unit - method key : int -> int -> Config.uioh - method private key1 : int -> int -> Config.uioh - method modehash : Config.keyhash - method motion : int -> int -> Config.uioh - method multiclick : int -> int -> int -> int -> Config.uioh - method nextcurlevel : int -> 'a - method pmotion : int -> int -> Config.uioh - method scroll : int -> int -> Config.uioh - method scrollph : int * float * float - method scrollpw : int * float * float - method updownlevel : int -> 'a - method zoom : float -> int -> int -> unit - end -val coe : < alwaysscrolly : bool; - button : int -> bool -> int -> int -> int -> #Config.uioh; - display : unit; eformsgs : bool; - infochanged : Config.infochange -> unit; - key : int -> int -> #Config.uioh; modehash : Config.keyhash; - motion : int -> int -> #Config.uioh; - multiclick : int -> int -> int -> int -> #Config.uioh; - pmotion : int -> int -> #Config.uioh; - scroll : int -> int -> #Config.uioh; - scrollph : int * float * float; scrollpw : int * float * float; - zoom : float -> int -> int -> unit; .. > -> Config.uioh -val setuioh : < alwaysscrolly : bool; - button : int -> bool -> int -> int -> int -> #Config.uioh; - display : unit; eformsgs : bool; - infochanged : Config.infochange -> unit; - key : int -> int -> #Config.uioh; modehash : Config.keyhash; - motion : int -> int -> #Config.uioh; - multiclick : int -> int -> int -> int -> #Config.uioh; - pmotion : int -> int -> #Config.uioh; - scroll : int -> int -> #Config.uioh; - scrollph : int * float * float; scrollpw : int * float * float; - zoom : float -> int -> int -> unit; .. > -> unit diff --git a/utf8syms.ml b/utf8syms.ml deleted file mode 100644 index 9b292ad..0000000 --- a/utf8syms.ml +++ /dev/null @@ -1,4 +0,0 @@ -let ellipsis = "\xe2\x80\xa6" -let radical = "\xe2\x88\x9a" -let lguillemet = "\xc2\xab" -let rguillemet = "\xc2\xbb" diff --git a/utils.ml b/utils.ml deleted file mode 100644 index 80eccde..0000000 --- a/utils.ml +++ /dev/null @@ -1,274 +0,0 @@ -exception Quit - -module E = struct - let s = "" - let b = Bytes.empty - let a = [||] - let j = (0, 0.0, 0.0) -end - -let tempfailureretry f a = - let rec g () = - try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g () - in g () - -external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn" -external hasdata : Unix.file_descr -> bool = "ml_hasdata" - -let now = Unix.gettimeofday -let dologf = ref prerr_endline -let dolog fmt = Printf.ksprintf !dologf fmt - -let exntos = function - | Unix.Unix_error (e, s, a) -> - Printf.sprintf "%s(%s) : %s (%d)" s a (Unix.error_message e) (Obj.magic e) - | exn -> Printexc.to_string exn - -let onoffs = function | true -> "on" | false -> "off" - -let error fmt = Printf.kprintf failwith fmt - -module IntSet = Set.Make (struct type t = int let compare = (-) end) - -let emptystr s = String.length s = 0 -let nonemptystr s = String.length s > 0 -let bound v minv maxv = max minv (min maxv v) - -module Opaque : sig - type t = private string - val of_string : string -> t - val to_string : t -> string -end = struct - type t = string - let of_string s = s - let to_string t = t -end - -let int_of_string_with_suffix s = - let l = String.length s in - let s1, shift = - if l > 1 - then - let p = l-1 in - match s.[p] with - | 'k' | 'K' -> String.sub s 0 p, 10 - | 'm' | 'M' -> String.sub s 0 p, 20 - | 'g' | 'G' -> String.sub s 0 p, 30 - | _ -> s, 0 - else s, 0 - in - let n = int_of_string s1 in - let m = n lsl shift in - if m < 0 || m < n - then error "value too large" - else m - -let string_with_suffix_of_int n = - let rec find = function - | [] -> Printf.sprintf "%#d" n - | (shift, suffix) :: rest -> - if (n land ((1 lsl shift) - 1)) = 0 - then Printf.sprintf "%#d%c" (n lsr shift) suffix - else find rest - in - if n = 0 then "0" else find [(30, 'G'); (20, 'M'); (10, 'K')] - -let color_of_string s = - Scanf.sscanf s "%d/%d/%d" (fun r g b -> - (float r /. 255.0, float g /. 255.0, float b /. 255.0) - ) - -let rgba_of_string s = - let c c = float c /. 255.0 in - Scanf.sscanf s "%d/%d/%d/%d" (fun r g b a -> c r, c g, c b, c a) - -let color_to_string (r, g, b) = - let c c = c *. 255.0 |> truncate in - Printf.sprintf "%d/%d/%d" (c r) (c g) (c b) - -let rgba_to_string (r, g, b, a) = - let c c = c *. 255.0 |> truncate in - Printf.sprintf "%d/%d/%d/%d" (c r) (c g) (c b) (c a) - -let abspath path = - if Filename.is_relative path - then - let cwd = Sys.getcwd () in - if Filename.is_implicit path - then Filename.concat cwd path - else Filename.concat cwd (Filename.basename path) - else path - -module Ne = struct - let index s c = try String.index s c with Not_found -> -1 - let clo fd f = - try tempfailureretry Unix.close fd - with exn -> f @@ exntos exn -end - -let getenvdef name def = - match Sys.getenv name with - | env -> env - | exception Not_found -> def - -module Re = struct - let crlf = Str.regexp "[\r\n]" - let percents = Str.regexp "%s" - let percentp = Str.regexp "%p" - let whitespace = Str.regexp "[ \t]" -end - -let addchar s c = - let b = Buffer.create (String.length s + 1) in - Buffer.add_string b s; - Buffer.add_char b c; - Buffer.contents b - -let btod b = if b then 1 else 0 - -let splitatchar s c = let open String in - match index s c with - | pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1) - | exception Not_found -> s, E.s - -let boundastep h step = - if step < 0 - then bound step ~-h 0 - else bound step 0 h - -let withoutlastutf8 s = - let len = String.length s in - if len = 0 - then s - else - let rec find pos = - if pos = 0 - then pos - else - let b = Char.code s.[pos] in - if b land 0b11000000 = 0b11000000 - then pos - else find (pos-1) - in - let first = - if Char.code s.[len-1] land 0x80 = 0 - then len-1 - else find (len-1) - in - String.sub s 0 first - -let fdcontents fd = - let l = 4096 in - let b = Buffer.create l in - let s = Bytes.create l in - let rec loop () = - let n = tempfailureretry (Unix.read fd s 0) l in - if n = 0 - then Buffer.contents b - else ( - Buffer.add_subbytes b s 0 n; - loop () - ) - in - loop () - -let filecontents path = - let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in - match fdcontents fd with - | exception exn -> - error "failed to read contents of %s: %s" path @@ exntos exn - | s -> - Ne.clo fd @@ error "failed to close descriptor for %s: %s" path; - s - -let getcmdoutput errfun cmd = - let reperror fmt = Printf.kprintf errfun fmt in - let clofail s e = error "failed to close %s: %s" s e in - match Unix.pipe () with - | exception exn -> - reperror "pipe failed: %s" @@ exntos exn; - E.s - | (r, w) -> - match spawn cmd [r, -1; w, 1] with - | exception exn -> - reperror "failed to execute %S: %s" cmd @@ exntos exn; - E.s - | pid -> - Ne.clo w @@ clofail "write end of the pipe"; - let s = - match Unix.waitpid [] pid with - | exception exn -> - reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn; - E.s - | _pid, Unix.WEXITED 0 -> - begin - match fdcontents r with - | exception exn -> - reperror "failed to read output of %S: %s" cmd @@ exntos exn; - E.s - | s -> - let l = String.length s in - if l > 0 && s.[l-1] = '\n' - then String.sub s 0 (l-1) - else s - end; - | _pid, Unix.WEXITED n -> - reperror "%S exited with error code %d" cmd n; - E.s - | _pid, Unix.WSIGNALED n -> - reperror "%S was killed with signal %d" cmd n; - E.s - | _pid, Unix.WSTOPPED n -> - reperror "%S was stopped by signal %d" cmd n; - E.s - in - Ne.clo r @@ clofail "read end of the pipe"; - s - -let geturl = - let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in - fun s -> if Str.string_match re s 0 - then Str.matched_group 1 s - else E.s - -let substratis s pos subs = - let subslen = String.length subs in - if String.length s - pos >= subslen - then - let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1) - in cmp 0 - else false - -let w8 = Bytes.set_uint8 -let r8 = Bytes.get_uint8 -let w16 = Bytes.set_uint16_le -let r16 = Bytes.get_uint16_le -let r16s = Bytes.get_int16_le -let w32 s pos i = w16 s pos i; w16 s (pos+2) (i lsr 16) -let r32 s pos = ((r16 s (pos+2)) lsl 16) lor (r16 s pos) -let r32s s pos = Bytes.get_int32_le s pos |> Int32.to_int - -let vlogf = ref ignore -let vlog fmt = Printf.kprintf !vlogf fmt - -let pipef ?(closew=true) cap f cmd = - match Unix.pipe () with - | exception exn -> dolog "%s cannot create pipe: %S" cap @@ exntos exn - | (r, w) -> - begin match spawn cmd [r, 0; w, -1] with - | exception exn -> dolog "%s: cannot execute %S: %s" cap cmd @@ exntos exn - | _pid -> f w - end; - Ne.clo r (dolog "%s failed to close r: %s" cap); - if closew then Ne.clo w (dolog "%s failed to close w: %s" cap) - -let selstring selcmd s = - pipef "selstring" (fun w -> - try - let l = String.length s in - let bytes = Bytes.unsafe_of_string s in - let n = tempfailureretry (Unix.write w bytes 0) l in - if n != l - then dolog "failed to write %d characters to sel pipe, wrote %d" l n; - with exn -> dolog "failed to write to sel pipe: %s" @@ exntos exn - ) selcmd diff --git a/utils.mli b/utils.mli deleted file mode 100644 index eddc006..0000000 --- a/utils.mli +++ /dev/null @@ -1,70 +0,0 @@ -exception Quit -module E : - sig - val s : string - val b : bytes - val a : 'a array - val j : int * float * float - end -val tempfailureretry : ('a -> 'b) -> 'a -> 'b -external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn" -external hasdata : Unix.file_descr -> bool = "ml_hasdata" -val now : unit -> float -val dologf : (string -> unit) ref -val dolog : ('a, unit, string, unit) format4 -> 'a -val exntos : exn -> string -val onoffs : bool -> string -val error : ('a, unit, string, 'b) format4 -> 'a -module IntSet : Set.S with type elt = int -val emptystr : string -> bool -val nonemptystr : string -> bool -val bound : 'a -> 'a -> 'a -> 'a -module Opaque : - sig - type t = private string - val of_string : string -> t - val to_string : t -> string - end -val int_of_string_with_suffix : string -> int -val string_with_suffix_of_int : int -> string -val color_of_string : string -> float * float * float -val rgba_of_string : string -> float * float * float * float -val color_to_string : float * float * float -> string -val rgba_to_string : float * float * float * float -> string -val abspath : string -> string -module Ne : - sig - val index : string -> char -> int - val clo : Unix.file_descr -> (string -> unit) -> unit - end -val getenvdef : string -> string -> string -module Re : - sig - val crlf : Str.regexp - val percents : Str.regexp - val percentp : Str.regexp - val whitespace : Str.regexp - end -val addchar : string -> char -> string -val btod : bool -> int -val splitatchar : string -> char -> string * string -val boundastep : int -> int -> int -val withoutlastutf8 : string -> string -val fdcontents : Unix.file_descr -> string -val filecontents : string -> string -val getcmdoutput : (string -> unit) -> string -> string -val geturl : string -> string -val substratis : string -> int -> string -> bool -val w8 : bytes -> int -> int -> unit -val r8 : bytes -> int -> int -val w16 : bytes -> int -> int -> unit -val r16 : bytes -> int -> int -val r16s : bytes -> int -> int -val w32 : bytes -> int -> int -> unit -val r32 : bytes -> int -> int -val r32s : bytes -> int -> int -val vlogf : (string -> unit) ref -val vlog : ('a, unit, string, unit) format4 -> 'a -val pipef : - ?closew:bool -> string -> (Unix.file_descr -> unit) -> string -> unit -val selstring : string -> string -> unit diff --git a/version.c b/version.c deleted file mode 100644 index c74483a..0000000 --- a/version.c +++ /dev/null @@ -1,3 +0,0 @@ -#define stringify1(x) #x -#define stringify(x) stringify1 (x) -const char llpp_version[] = stringify (LLPP_VERSION); diff --git a/wsi/cocoa/cocoa.m b/wsi/cocoa/cocoa.m deleted file mode 100644 index f225754..0000000 --- a/wsi/cocoa/cocoa.m +++ /dev/null @@ -1,926 +0,0 @@ -#include -#include - -#define CAML_NAME_SPACE - -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -enum { - EVENT_EXPOSE = 1, - EVENT_RESHAPE = 3, - EVENT_MOUSE = 4, - EVENT_MOTION = 5, - EVENT_PMOTION = 6, - EVENT_KEYDOWN = 7, - EVENT_ENTER = 8, - EVENT_LEAVE = 9, - EVENT_WINSTATE = 10, - EVENT_QUIT = 11, - EVENT_SCROLL = 12, - EVENT_ZOOM = 13, - EVENT_OPEN = 20 -}; - -enum { - BUTTON_LEFT = 1, - BUTTON_RIGHT = 3, - BUTTON_WHEEL_UP = 4, - BUTTON_WHEEL_DOWN = 5 -}; - -static int terminating = 0; -static pthread_mutex_t terminate_mutex = PTHREAD_MUTEX_INITIALIZER; -static int server_fd = -1; -static CGFloat backing_scale_factor = -1.0; - -#if __MAC_OS_X_VERSION_MAX_ALLOWED >= 10120 - -#define NS_CRITICAL_ALERT_STYLE NSAlertStyleCritical -#define NS_FULL_SCREEN_WINDOW_MASK NSWindowStyleMaskFullScreen -#define NS_DEVICE_INDEPENDENT_MODIFIER_FLAGS_MASK NSEventModifierFlagDeviceIndependentFlagsMask -#define NS_FUNCTION_KEY_MASK NSEventModifierFlagFunction -#define NS_ALTERNATE_KEY_MASK NSEventModifierFlagOption -#define NS_COMMAND_KEY_MASK NSEventModifierFlagCommand -#define NS_CLOSABLE_WINDOW_MASK NSWindowStyleMaskClosable -#define NS_MINIATURIZABLE_WINDOW_MASK NSWindowStyleMaskMiniaturizable -#define NS_TITLED_WINDOW_MASK NSWindowStyleMaskTitled -#define NS_RESIZABLE_WINDOW_MASK NSWindowStyleMaskResizable - -#else - -#define NS_CRITICAL_ALERT_STYLE NSCriticalAlertStyle -#define NS_FULL_SCREEN_WINDOW_MASK NSFullScreenWindowMask -#define NS_DEVICE_INDEPENDENT_MODIFIER_FLAGS_MASK NSDeviceIndependentModifierFlagsMask -#define NS_FUNCTION_KEY_MASK NSFunctionKeyMask -#define NS_ALTERNATE_KEY_MASK NSAlternateKeyMask -#define NS_COMMAND_KEY_MASK NSCommandKeyMask -#define NS_CLOSABLE_WINDOW_MASK NSClosableWindowMask -#define NS_MINIATURIZABLE_WINDOW_MASK NSMiniaturizableWindowMask -#define NS_TITLED_WINDOW_MASK NSTitledWindowMask -#define NS_RESIZABLE_WINDOW_MASK NSResizableWindowMask - -#endif - -void Abort (NSString *format, ...) -{ - va_list argList; - va_start (argList, format); - NSString *str = [[NSString alloc] initWithFormat:format arguments:argList]; - va_end (argList); - NSLog (@"%@", str); - NSAlert *alert = [[NSAlert alloc] init]; - [alert addButtonWithTitle:@"Quit"]; - [alert setMessageText:@"Internal Error"]; - [alert setInformativeText:str]; - [alert setAlertStyle:NS_CRITICAL_ALERT_STYLE]; - [alert runModal]; - [NSApp terminate:nil]; -} - -void *caml_main_thread (void *argv) -{ - @autoreleasepool { - caml_main (argv); - pthread_mutex_lock (&terminate_mutex); - if (terminating == 0) { - terminating = 1; - [NSApp performSelectorOnMainThread:@selector(terminate:) - withObject:nil - waitUntilDone:NO]; - } - pthread_mutex_unlock (&terminate_mutex); - } - pthread_exit (NULL); -} - -NSCursor *GetCursor (int idx) -{ - static NSCursor *cursors[5]; - static BOOL initialised = NO; - - if (initialised == NO) { - cursors[0] = [NSCursor arrowCursor]; - cursors[1] = [NSCursor pointingHandCursor]; - cursors[2] = [NSCursor arrowCursor]; - cursors[3] = [NSCursor closedHandCursor]; - cursors[4] = [NSCursor IBeamCursor]; - initialised = YES; - } - - return cursors[idx]; -} - -@implementation NSWindow (CategoryNSWindow) - -- (BOOL)isFullScreen -{ - return ([self styleMask] & NS_FULL_SCREEN_WINDOW_MASK) == NS_FULL_SCREEN_WINDOW_MASK; -} - -@end - -@implementation NSView (CategoryNSView) - -- (NSPoint)locationFromEvent:(NSEvent *)event -{ - NSPoint point = - [self convertPointToBacking:[self convertPoint:[event locationInWindow] fromView:nil]]; - NSRect bounds = [self convertRectToBacking:[self bounds]]; - point.y = bounds.size.height - point.y; - return point; -} - -- (NSRect)convertFrameToBacking -{ - return [self convertRectToBacking:[self frame]]; -} - -@end - -@implementation NSEvent (CategoryNSEvent) - -- (int)deviceIndependentModifierFlags -{ - return [self modifierFlags] & NS_DEVICE_INDEPENDENT_MODIFIER_FLAGS_MASK; -} - -@end - -@interface Connector : NSObject - -- (instancetype)initWithFileDescriptor:(int)fd; - -- (void)notifyReshapeWidth:(int)w height:(int)h; -- (void)notifyExpose; -- (void)keyDown:(uint32_t)key modifierFlags:(NSEventModifierFlags)mask; -- (void)notifyQuit; -- (void)mouseEntered:(NSPoint)loc; -- (void)mouseExited; -- (void)mouseMoved:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags; -- (void)mouseDown:(NSUInteger)buttons atPoint:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags; -- (void)mouseUp:(NSUInteger)buttons atPoint:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags; -@end - -@implementation Connector -{ - NSMutableData *data; - NSFileHandle *fileHandle; -} - -- (instancetype)initWithFileDescriptor:(int)fd -{ - self = [super init]; - data = [NSMutableData dataWithLength:32]; - fileHandle = [[NSFileHandle alloc] initWithFileDescriptor:fd]; - return self; -} - -- (void)setByte:(int8_t)b offset:(int)off -{ - [data replaceBytesInRange:NSMakeRange (off, 1) withBytes:&b]; -} - -- (void)setShort:(int16_t)s offset:(int)off -{ - [data replaceBytesInRange:NSMakeRange (off, 2) withBytes:&s]; -} - -- (void)setInt:(int32_t)n offset:(int)off -{ - [data replaceBytesInRange:NSMakeRange (off, 4) withBytes:&n]; -} - -- (void)writeData -{ - [fileHandle writeData:data]; -} - -- (void)notifyReshapeWidth:(int)w height:(int)h -{ - [self setByte:EVENT_RESHAPE offset:0]; - [self setShort:w offset:16]; - [self setShort:h offset:18]; - [self writeData]; -} - -- (void)notifyExpose -{ - [self setByte:EVENT_EXPOSE offset:0]; - [self writeData]; -} - -- (void)keyDown:(uint32_t)key modifierFlags:(NSEventModifierFlags)mask -{ - [self setByte:EVENT_KEYDOWN offset:0]; - [self setInt:key offset:16]; - [self setInt:mask offset:20]; - [self writeData]; -} - -- (void)notifyWinstate:(BOOL)fullScreen -{ - [self setByte:EVENT_WINSTATE offset:0]; - [self setInt:fullScreen offset:16]; - [self writeData]; -} - -- (void)notifyQuit -{ - [self setByte:EVENT_QUIT offset:0]; - [self writeData]; -} - -- (void)mouseEntered:(NSPoint)loc -{ - [self setByte:EVENT_ENTER offset:0]; - [self setShort:loc.x offset:16]; - [self setShort:loc.y offset:20]; - [self writeData]; -} - -- (void)mouseExited -{ - [self setByte:EVENT_LEAVE offset:0]; - [self writeData]; -} - -- (void)mouseDragged:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags -{ - [self setByte:EVENT_MOTION offset:0]; - [self setShort:aPoint.x offset:16]; - [self setShort:aPoint.y offset:20]; - [self setInt:flags offset:24]; - [self writeData]; -} - -- (void)mouseMoved:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags -{ - [self setByte:EVENT_PMOTION offset:0]; - [self setShort:aPoint.x offset:16]; - [self setShort:aPoint.y offset:20]; - [self setInt:flags offset:24]; - [self writeData]; -} - -- (void)mouseDown:(NSUInteger)buttons atPoint:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags -{ - [self setByte:EVENT_MOUSE offset:0]; - [self setShort:1 offset:10]; - [self setInt:buttons offset:12]; - [self setShort:aPoint.x offset:16]; - [self setShort:aPoint.y offset:20]; - [self setInt:flags offset:24]; - [self writeData]; -} - -- (void)mouseUp:(NSUInteger)buttons atPoint:(NSPoint)aPoint modifierFlags:(NSEventModifierFlags)flags -{ - [self setByte:EVENT_MOUSE offset:0]; - [self setShort:0 offset:10]; - [self setInt:buttons offset:12]; - [self setShort:aPoint.x offset:16]; - [self setShort:aPoint.y offset:20]; - [self setInt:flags offset:24]; - [self writeData]; -} - -- (void)scrollByDeltaX:(CGFloat)deltaX deltaY:(CGFloat)deltaY -{ - [self setByte:EVENT_SCROLL offset:0]; - [self setInt:(int32_t) deltaX offset:16]; - [self setInt:(int32_t) deltaY offset:20]; - [self writeData]; -} - -- (void)zoom:(CGFloat)z at:(NSPoint)p -{ - [self setByte:EVENT_ZOOM offset:0]; - [self setInt:(int32_t) (z * 1000) offset:16]; - [self setShort:p.x offset:20]; - [self setShort:p.y offset:22]; - [self writeData]; -} - -- (void)openFile:(NSString *)filename -{ - const char *utf8 = [filename UTF8String]; - unsigned len = [filename lengthOfBytesUsingEncoding:NSUTF8StringEncoding]; - [self setByte:EVENT_OPEN offset:0]; - unsigned off = 0; - unsigned data_len = [data length] - 4; - while (off < len) { - unsigned chunk_len = MIN (data_len - 4, len - off); - [self setShort:chunk_len offset:2]; - [data replaceBytesInRange:NSMakeRange (4, chunk_len) withBytes:(utf8 + off)]; - [self writeData]; - off += chunk_len; - } - [self setShort:0 offset:2]; - [self writeData]; -} - -@end - -@interface MyDelegate : NSObject - -- (int)getw; -- (int)geth; -- (void)swapb; -- (void)applicationWillFinishLaunching:(NSNotification *)not; -- (void)applicationDidFinishLaunching:(NSNotification *)not; -- (BOOL)applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)theApplication; -- (void)makeCurrentContext; - -@end - -@interface MyWindow : NSWindow - -@end - -@interface MyView : NSOpenGLView -{ - Connector *connector; - NSCursor *cursor; -} - -- (instancetype)initWithFrame:(NSRect)frame connector:(Connector *)aConnector; -- (void)setCursor:(NSCursor *)aCursor; - -@end - -@implementation MyView - -- (instancetype)initWithFrame:(NSRect)frame connector:(Connector *)aConnector -{ - NSOpenGLPixelFormatAttribute attrs[] = - { - NSOpenGLPFAAccelerated, - NSOpenGLPFADoubleBuffer, - NSOpenGLPFAColorSize, 24, - NSOpenGLPFAAlphaSize, 8, - NSOpenGLPFADepthSize, 24, - 0 - }; - NSOpenGLPixelFormat *pixFormat = [[NSOpenGLPixelFormat alloc] initWithAttributes:attrs]; - self = [super initWithFrame:frame pixelFormat:pixFormat]; - - if (self != NULL) { - connector = aConnector; - cursor = [NSCursor arrowCursor]; - self.allowedTouchTypes = NSTouchTypeMaskDirect | NSTouchTypeMaskIndirect; - [self setWantsBestResolutionOpenGLSurface:YES]; - } - - return self; -} - -- (void)setCursor:(NSCursor *)aCursor -{ - cursor = aCursor; -} - --(void)resetCursorRects -{ - [self addCursorRect:[self bounds] cursor:cursor]; -} - -- (void)drawRect:(NSRect)bounds -{ - // NSLog(@"drawRect: %@", [NSValue valueWithRect:bounds]); - [connector notifyExpose]; -} - -- (void)viewWillMoveToWindow:(NSWindow *)newWindow { - NSTrackingArea* trackingArea = [[NSTrackingArea alloc] - initWithRect:[self bounds] - options:(NSTrackingMouseEnteredAndExited | NSTrackingActiveInActiveApp | NSTrackingInVisibleRect) - owner:self - userInfo:nil]; - [self addTrackingArea:trackingArea]; -} - -- (void)keyDown:(NSEvent *)event -{ - // int key = [event keyCode]; - NSEventModifierFlags mask = [event deviceIndependentModifierFlags]; - NSString *chars = [event charactersIgnoringModifiers]; - const uint32_t *c = (uint32_t *) [chars cStringUsingEncoding:NSUTF32LittleEndianStringEncoding]; - while (*c) { - if (*c == 0x7f && !(mask & NS_FUNCTION_KEY_MASK)) { - [connector keyDown:0x8 modifierFlags:mask]; - } else { - [connector keyDown:*c modifierFlags:mask]; - } - c++; - } -} - -- (void)flagsChanged:(NSEvent *)event -{ - NSEventModifierFlags mask = [event deviceIndependentModifierFlags]; - //NSLog (@"flagsChanged: 0x%lx", mask); - if (mask != 0) { - [connector keyDown:0 modifierFlags:mask]; - } -} - -- (void)mouseDown:(NSEvent *)event -{ - [connector mouseDown:BUTTON_LEFT - atPoint:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)mouseUp:(NSEvent *)event -{ - [connector mouseUp:BUTTON_LEFT - atPoint:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)rightMouseDown:(NSEvent *)event -{ - [connector mouseDown:BUTTON_RIGHT - atPoint:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)rightMouseUp:(NSEvent *)event -{ - [connector mouseUp:BUTTON_RIGHT - atPoint:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)rightMouseDragged:(NSEvent *)event -{ - [connector mouseDragged:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)mouseDragged:(NSEvent *)event -{ - [connector mouseDragged:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)mouseMoved:(NSEvent *)event -{ - [connector mouseMoved:[self locationFromEvent:event] - modifierFlags:[event deviceIndependentModifierFlags]]; -} - -- (void)mouseEntered:(NSEvent *)event -{ - [connector mouseEntered:[self locationFromEvent:event]]; -} - -- (void)mouseExited:(NSEvent *)event -{ - [connector mouseExited]; -} - -- (void)scrollWheel:(NSEvent *)event -{ - CGFloat deltaX = [event scrollingDeltaX]; - CGFloat deltaY = -[event scrollingDeltaY]; - - if ([event hasPreciseScrollingDeltas]) { - [connector scrollByDeltaX:(backing_scale_factor * deltaX) - deltaY:(backing_scale_factor * deltaY)]; - } else { - NSPoint loc = [self locationFromEvent:event]; - NSEventModifierFlags mask = [event deviceIndependentModifierFlags]; - if (deltaY > 0.0) { - [connector mouseDown:BUTTON_WHEEL_DOWN atPoint:loc modifierFlags:mask]; - [connector mouseUp:BUTTON_WHEEL_DOWN atPoint:loc modifierFlags:mask]; - } else if (deltaY < 0.0) { - [connector mouseDown:BUTTON_WHEEL_UP atPoint:loc modifierFlags:mask]; - [connector mouseUp:BUTTON_WHEEL_UP atPoint:loc modifierFlags:mask]; - } - } -} - -- (void)magnifyWithEvent:(NSEvent *)event -{ - [connector zoom:[event magnification] at:[self locationFromEvent:event]]; -} - -@end - -@implementation MyWindow - -- (BOOL)canBecomeKeyWindow -{ - return YES; -} - -@end - -@implementation MyDelegate -{ - char **argv; - MyWindow *window; - NSOpenGLContext *glContext; - pthread_t thread; - Connector *connector; -} - -- (instancetype)initWithArgv:(char **)theArgv fileDescriptor:(int)fd -{ - self = [super init]; - if (self != NULL) { - argv = theArgv; - connector = [[Connector alloc] initWithFileDescriptor:fd]; - } - return self; -} - -- (void)setTitle:(NSString *)title -{ - [window setTitle:title]; -} - -- (void)mapwin -{ - [window makeKeyAndOrderFront:self]; -} - -- (int)getw -{ - return [[window contentView] convertFrameToBacking].size.width; -} - -- (int)geth -{ - return [[window contentView] convertFrameToBacking].size.height; -} - -- (void)applicationWillFinishLaunching:(NSNotification *)not -{ - NSLog(@"applicationWillFinishLaunching"); - id menubar = [NSMenu new]; - id appMenuItem = [NSMenuItem new]; - id fileMenuItem = [NSMenuItem new]; - id windowMenuItem = [NSMenuItem new]; - id helpMenuItem = [NSMenuItem new]; - [menubar addItem:appMenuItem]; - [menubar addItem:fileMenuItem]; - [menubar addItem:windowMenuItem]; - [menubar addItem:helpMenuItem]; - [NSApp setMainMenu:menubar]; - id appMenu = [NSMenu new]; - id appName = [[NSProcessInfo processInfo] processName]; - id aboutMenuItem = [[NSMenuItem alloc] initWithTitle:[@"About " stringByAppendingString:appName] - action:@selector(orderFrontStandardAboutPanel:) - keyEquivalent:@""]; - id hideMenuItem = [[NSMenuItem alloc] initWithTitle:[@"Hide " stringByAppendingString:appName] - action:@selector(hide:) - keyEquivalent:@"h"]; - id hideOthersMenuItem = [[NSMenuItem alloc] initWithTitle:@"Hide Others" - action:@selector(hideOtherApplications:) - keyEquivalent:@"h"]; - [hideOthersMenuItem setKeyEquivalentModifierMask:(NS_ALTERNATE_KEY_MASK | NS_COMMAND_KEY_MASK)]; - id showAllMenuItem = [[NSMenuItem alloc] initWithTitle:@"Show All" - action:@selector(unhideAllApplications:) - keyEquivalent:@""]; - id quitMenuItem = [[NSMenuItem alloc] initWithTitle:[@"Quit " stringByAppendingString:appName] - action:@selector(terminate:) - keyEquivalent:@"q"]; - [appMenu addItem:aboutMenuItem]; - [appMenu addItem:[NSMenuItem separatorItem]]; - [appMenu addItem:hideMenuItem]; - [appMenu addItem:hideOthersMenuItem]; - [appMenu addItem:showAllMenuItem]; - [appMenu addItem:[NSMenuItem separatorItem]]; - [appMenu addItem:quitMenuItem]; - [appMenuItem setSubmenu:appMenu]; - - id fileMenu = [[NSMenu alloc] initWithTitle:@"File"]; - id openMenuItem = [[NSMenuItem alloc] initWithTitle:@"Open..." - action:@selector(openDocument:) - keyEquivalent:@"o"]; - id closeMenuItem = [[NSMenuItem alloc] initWithTitle:@"Close" - action:@selector(performClose:) - keyEquivalent:@"w"]; - [fileMenu addItem:openMenuItem]; - [fileMenu addItem:[NSMenuItem separatorItem]]; - [fileMenu addItem:closeMenuItem]; - [fileMenuItem setSubmenu:fileMenu]; - - id windowMenu = [[NSMenu alloc] initWithTitle:@"Window"]; - id miniaturizeMenuItem = [[NSMenuItem alloc] initWithTitle:@"Minimize" - action:@selector(performMiniaturize:) - keyEquivalent:@"m"]; - id zoomMenuItem = [[NSMenuItem alloc] initWithTitle:@"Zoom" - action:@selector(performZoom:) - keyEquivalent:@""]; - - [windowMenu addItem:miniaturizeMenuItem]; - [windowMenu addItem:zoomMenuItem]; - [windowMenuItem setSubmenu:windowMenu]; - - id helpMenu = [[NSMenu alloc] initWithTitle:@"Help"]; - id reportIssueMenuItem = [[NSMenuItem alloc] initWithTitle:@"Report an issue..." - action:@selector(reportIssue:) - keyEquivalent:@""]; - [helpMenu addItem:reportIssueMenuItem]; - [helpMenuItem setSubmenu:helpMenu]; - - window = [[MyWindow alloc] initWithContentRect:NSMakeRect(0, 0, 400, 400) - styleMask:(NS_CLOSABLE_WINDOW_MASK | NS_MINIATURIZABLE_WINDOW_MASK | NS_TITLED_WINDOW_MASK | NS_RESIZABLE_WINDOW_MASK) - backing:NSBackingStoreBuffered - defer:NO]; - - [window center]; - [window setAcceptsMouseMovedEvents:YES]; - [window setDelegate:self]; - - - [[NSNotificationCenter defaultCenter] addObserver:self - selector:@selector(didEnterFullScreen) - name:NSWindowDidEnterFullScreenNotification - object:window]; - [[NSNotificationCenter defaultCenter] addObserver:self - selector:@selector(didExitFullScreen) - name:NSWindowDidExitFullScreenNotification - object:window]; - - MyView *myView = [[MyView alloc] initWithFrame:[[window contentView] bounds] - connector:connector]; - - [window setContentView:myView]; - [window makeFirstResponder:myView]; - - glContext = [myView openGLContext]; - GLint swapInt = 1; - [glContext setValues:&swapInt forParameter:NSOpenGLContextParameterSwapInterval]; - - backing_scale_factor = [window backingScaleFactor]; -} - -- (void)reshape:(NSValue *)val -{ - // NSLog (@"reshape: %@ isFullScreen: %d", val, [window isFullScreen]); - if ([window isFullScreen]) { - [window toggleFullScreen:self]; - } - [window setFrame:[window frameRectForContentRect:[val rectValue]] - display:YES]; -} - -- (void)makeCurrentContext -{ - [glContext makeCurrentContext]; - NSLog (@"OpenGL Version: %s", glGetString(GL_VERSION)); -} - -- (void)swapb -{ - [glContext flushBuffer]; -} - -- (void)didEnterFullScreen -{ - // NSLog (@"didEnterFullScreen: %d", [window isFullScreen]); - [connector notifyWinstate:YES]; -} - -- (void)didExitFullScreen -{ - // NSLog (@"didExitFullScreen: %d", [window isFullScreen]); - [connector notifyWinstate:NO]; -} - -- (void)fullscreen -{ - // NSLog (@"fullscreen: %d", [window isFullScreen]); - if ([window isFullScreen] == NO) { - [window toggleFullScreen:self]; - } -} - -- (void)setCursor:(NSCursor *)aCursor -{ - [[window contentView] setCursor: aCursor]; - [window invalidateCursorRectsForView:[window contentView]]; -} - -- (void)windowDidResize:(NSNotification *)notification -{ - NSRect frame = [[window contentView] convertFrameToBacking]; - [connector notifyReshapeWidth:frame.size.width height:frame.size.height]; -} - -- (void)applicationWillTerminate:(NSDictionary *)userInfo -{ - pthread_mutex_lock (&terminate_mutex); - if (terminating == 0) { - terminating = 1; - [connector notifyQuit]; - } - pthread_mutex_unlock (&terminate_mutex); - pthread_join (thread, NULL); -} - -- (void)windowDidChangeOcclusionState:(NSNotification *)notification -{ -} - -- (void)applicationDidFinishLaunching:(NSNotification *)not -{ - NSLog(@"applicationDidFinishLaunching"); - int ret = pthread_create (&thread, NULL, caml_main_thread, argv); - if (ret != 0) { - Abort (@"pthread_create: %s.", strerror (ret)); - } -} - -- (BOOL)applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)theApplication -{ - return YES; -} - -- (BOOL)application:(NSApplication *)theApplication openFile:(NSString *)filename -{ - NSLog (@"openFile: %@", filename); - [connector openFile:filename]; - return YES; -} - -- (void)openDocument:(id)sender -{ - NSOpenPanel *openPanel = [NSOpenPanel openPanel]; - [openPanel beginSheetModalForWindow:window - completionHandler:^(NSInteger result){ - if (result == NSModalResponseOK) { - NSString *filename = [[[openPanel URLs] objectAtIndex:0] path]; - if (filename != nil) { - [self application:NSApp openFile:filename]; - } - } - }]; -} - -- (void)reportIssue:(id)sender -{ - [[NSWorkspace sharedWorkspace] - openURL:[NSURL URLWithString:@"https://github.com/moosotc/llpp/issues"]]; -} - -@end - -CAMLprim value ml_mapwin (value unit) -{ - CAMLparam1 (unit); - [(MyDelegate *)[NSApp delegate] performSelectorOnMainThread:@selector(mapwin) - withObject:nil - waitUntilDone:YES]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_swapb (value unit) -{ - CAMLparam1 (unit); - [(MyDelegate *)[NSApp delegate] swapb]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_getw (value unit) -{ - return Val_int([(MyDelegate *)[NSApp delegate] getw]); -} - -CAMLprim value ml_geth (value unit) -{ - return Val_int([(MyDelegate *)[NSApp delegate] geth]); -} - -CAMLprim value ml_makecurrentcontext (value unit) -{ - CAMLparam1 (unit); - [(MyDelegate *)[NSApp delegate] makeCurrentContext]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_settitle (value title) -{ - CAMLparam1 (title); - NSString *str = [NSString stringWithUTF8String:String_val(title)]; - [(MyDelegate *)[NSApp delegate] performSelectorOnMainThread:@selector(setTitle:) - withObject:str - waitUntilDone:YES]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_reshape (value w, value h) -{ - CAMLparam2 (w, h); - NSRect r = NSMakeRect (0, 0, Int_val (w), Int_val (h)); - [(MyDelegate *)[NSApp delegate] performSelectorOnMainThread:@selector(reshape:) - withObject:[NSValue valueWithRect:r] - waitUntilDone:YES]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_fullscreen (value unit) -{ - CAMLparam1 (unit); - [(MyDelegate *)[NSApp delegate] performSelectorOnMainThread:@selector(fullscreen) - withObject:nil - waitUntilDone:YES]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_setcursor (value curs) -{ - CAMLparam1 (curs); - // NSLog (@"ml_setcursor: %d", Int_val (curs)); - NSCursor *cursor = GetCursor (Int_val (curs)); - [(MyDelegate *)[NSApp delegate] performSelectorOnMainThread:@selector(setCursor:) - withObject:cursor - waitUntilDone:YES]; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_get_server_fd (value unit) -{ - CAMLparam1 (unit); - CAMLreturn (Val_int (server_fd)); -} - -CAMLprim value ml_get_backing_scale_factor (value unit) -{ - CAMLparam1 (unit); - CAMLreturn (Val_int ((int) backing_scale_factor)); -} - -CAMLprim value ml_nslog (value str) -{ - CAMLparam1 (str); - NSLog (@"%s", String_val (str)); - CAMLreturn (Val_unit); -} - -// HACK to eliminate arg injected by OS X -psn_... -int adjust_argv (int argc, char **argv) -{ - if (argc > 1 && strncmp (argv[1], "-psn", 4) == 0) { - for (unsigned i = 1; i < argc - 1; i ++) { - argv[i] = argv[i+1]; - } - argv[-- argc] = 0; - } - for (int i = 0; i < argc; i ++) { - NSLog (@"arg %d: %s", i, argv[i]); - } - return argc; -} - -void (*wsigladdr (const char *name)) (void) -{ - static CFBundleRef framework = NULL; - if (framework == NULL) - framework = CFBundleGetBundleWithIdentifier (CFSTR ("com.apple.opengl")); - - char *bytes; - CFStringRef str; - size_t namelenp1 = strlen (name) + 1; - bytes = CFAllocatorAllocate (CFAllocatorGetDefault(), namelenp1, 0); - memcpy (bytes, name, namelenp1); - str = CFStringCreateWithCStringNoCopy (NULL, bytes, - kCFStringEncodingMacRoman, NULL); - void (*ret) (void) = CFBundleGetFunctionPointerForName (framework, str); - CFRelease (str); - return ret; -} - -int main(int argc, char **argv) -{ - @autoreleasepool { - int sv[2]; - int ret = socketpair (AF_UNIX, SOCK_STREAM, 0, sv); - if (ret != 0) { - Abort (@"socketpair: %s", strerror (errno)); - } - // NSLog (@"socketpair sv0 %d sv1 %d", sv[0], sv[1]); - server_fd = sv[0]; - argc = adjust_argv (argc, argv); - [NSApplication sharedApplication]; - [NSApp setActivationPolicy:NSApplicationActivationPolicyRegular]; - id delegate = [[MyDelegate alloc] initWithArgv:argv fileDescriptor:sv[1]]; - [NSApp setDelegate:delegate]; - [NSApp activateIgnoringOtherApps:YES]; - [NSApp run]; - } - return EXIT_SUCCESS; -} diff --git a/wsi/cocoa/genplist.sh b/wsi/cocoa/genplist.sh deleted file mode 100644 index 197f6f9..0000000 --- a/wsi/cocoa/genplist.sh +++ /dev/null @@ -1,54 +0,0 @@ -cat < - - - - BuildMachineOSBuild - 15G31 - CFBundleDevelopmentRegion - en - CFBundleDocumentTypes - - - CFBundleTypeExtensions - - pdf - - CFBundleTypeName - PDF File - CFBundleTypeRole - Viewer - LSTypeIsPackage - - LSItemContentTypes - - com.adobe.pdf - - - - CFBundleExecutable - llpp - CFBundleIdentifier - llpp.llpp - CFBundleInfoDictionaryVersion - 6.0 - CFBundleName - llpp - CFBundlePackageType - APPL - CFBundleSignature - ???? - CFBundleSupportedPlatforms - - MacOSX - - CFBundleVersion - $ver - LSMinimumSystemVersion - 10.10 - NSPrincipalClass - NSApplication - - -EOF diff --git a/wsi/cocoa/wsi.ml b/wsi/cocoa/wsi.ml deleted file mode 100644 index f9f6ed8..0000000 --- a/wsi/cocoa/wsi.ml +++ /dev/null @@ -1,316 +0,0 @@ -open Utils - -type cursor = - | CURSOR_INHERIT - | CURSOR_INFO - | CURSOR_CYCLE - | CURSOR_FLEUR - | CURSOR_TEXT - -type winstate = - | MaxVert - | MaxHorz - | Fullscreen - -type visiblestate = - | Unobscured - | PartiallyObscured - | FullyObscured - -let onot = object - method display = () - method map _ = () - method expose = () - method visible _ = () - method reshape _ _ = () - method mouse _ _ _ _ _ = () - method motion _ _ = () - method pmotion _ _ = () - method key _ _ = () - method enter _ _ = () - method leave = () - method winstate _ = () - method quit : 'a. 'a = exit 0 - method scroll _ _ = () - method zoom _ _ _ = () - method opendoc _ = () -end - -class type t = object - method display : unit - method map : bool -> unit - method expose : unit - method visible : visiblestate -> unit - method reshape : int -> int -> unit - method mouse : int -> bool -> int -> int -> int -> unit - method motion : int -> int -> unit - method pmotion : int -> int -> unit - method key : int -> int -> unit - method enter : int -> int -> unit - method leave : unit - method winstate : winstate list -> unit - method quit : 'a. 'a - method scroll : int -> int -> unit - method zoom : float -> int -> int -> unit - method opendoc : string -> unit -end - -type state = - { - mutable t: t; - mutable fd: Unix.file_descr; - buf: bytes; - mutable off: int; - path: Buffer.t; - } - -let state = - { - t = onot; - fd = Unix.stdin; - buf = Bytes.create 512; - off = 0; - path = Buffer.create 0; - } - -external setcursor: cursor -> unit = "ml_setcursor" -external settitle: string -> unit = "ml_settitle" -external swapb: unit -> unit = "ml_swapb" -external reshape: int -> int -> unit = "ml_reshape" -external makecurrentcontext: unit -> unit = "ml_makecurrentcontext" -external getw: unit -> int = "ml_getw" -external geth: unit -> int = "ml_geth" -external get_server_fd: unit -> Unix.file_descr = "ml_get_server_fd" -external get_backing_scale_factor: unit -> int = "ml_get_backing_scale_factor" -external fullscreen: unit -> unit = "ml_fullscreen" -external mapwin: unit -> unit = "ml_mapwin" -external nslog: string -> unit = "ml_nslog" - -let nslog fmt = - Printf.ksprintf nslog fmt - -(* 0 -> map - 1 -> expose - 2 -> visible - 3 -> reshape - 4 -> mouse - 5 -> motion - 6 -> pmotion - 7 -> key - 8 -> enter - 9 -> leave - 10 -> winstate - 11 -> quit - 12 -> scroll - 13 -> zoom - 20 -> open *) - -let handleresp resp = - let opcode = r8 resp 0 in - match opcode with - | 0 -> - let mapped = r8 resp 16 <> 0 in - vlog "map %B" mapped; - state.t#map mapped - | 1 -> - vlog "expose"; - state.t#expose - | 3 -> - let w = r16 resp 16 in - let h = r16 resp 18 in - vlog "reshape width %d height %d" w h; - state.t#reshape w h - | 4 -> - let down = r16 resp 10 <> 0 in - let b = r32 resp 12 in - let x = r16s resp 16 in - let y = r16s resp 20 in - let m = r32 resp 24 in - vlog "mouse %s b %d x %d y %d m 0x%x" (if down then "down" else "up") b x y m; - state.t#mouse b down x y m - | 5 -> - let x = r16s resp 16 in - let y = r16s resp 20 in - let m = r32 resp 24 in - vlog "motion x %d y %d m 0x%x" x y m; - state.t#motion x y - | 6 -> - let x = r16s resp 16 in - let y = r16s resp 20 in - let m = r32 resp 24 in - vlog "pmotion x %d y %d m 0x%x" x y m; - state.t#pmotion x y - | 7 -> - let key = r32 resp 16 in - let mask = r32 resp 20 in - vlog "keydown key %d mask %d" key mask; - state.t#key key mask - | 8 -> - let x = r16s resp 16 in - let y = r16s resp 20 in - vlog "enter x %d y %d" x y; - state.t#enter x y - | 9 -> - vlog "leave"; - state.t#leave - | 10 -> - let x = r32 resp 16 <> 0 in - vlog "winstate %B" x; - state.t#winstate (if x then [Fullscreen] else []); - | 11 -> - vlog "quit"; - state.t#quit - | 12 -> - let dx = r32s resp 16 in - let dy = r32s resp 20 in - vlog "scroll dx %d dy %d" dx dy; - state.t#scroll dx dy - | 13 -> - let z = float (r32s resp 16) /. 1000.0 in - let x = r16s resp 20 in - let y = r16s resp 22 in - vlog "zoom z %f x %d y %d" z x y; - state.t#zoom z x y - | 20 -> - begin match r16 resp 2 with - | 0 -> - let path = Buffer.contents state.path in - Buffer.reset state.path; - if false then nslog "open %S" path; - state.t#opendoc path - | chunk_len -> - if false then nslog "open-append %S" (Bytes.sub_string resp 4 chunk_len); - Buffer.add_subbytes state.path resp 4 chunk_len - end - | _ -> - vlog "unknown server message %d" opcode - -let readresp sock = - let len = - match Unix.read sock state.buf state.off (Bytes.length state.buf - state.off) with - | exception Unix.Unix_error (Unix.EINTR, _, _) -> state.off - | 0 -> state.t#quit - | n -> state.off + n - in - let rec loop off = - (* vlog "loop off=%d len=%d\n%!" off len; *) - if off + 32 <= len then begin - let resp = Bytes.sub state.buf off 32 in - handleresp resp; - loop (off + 32) - end else if off < len then begin - Bytes.blit state.buf off state.buf 0 (len - off); - state.off <- len - state.off - end else - state.off <- 0 - in - loop 0 - -let fontsizescale n = - n * get_backing_scale_factor () - -let init t w h = - let fd = get_server_fd () in - state.t <- t; - state.fd <- fd; - makecurrentcontext (); - reshape w h; - fd, getw (), geth () - -let activatewin () = () - -let metamask = 1 lsl 19 - -let altmask = 1 lsl 19 - -let shiftmask = 1 lsl 17 - -let ctrlmask = 1 lsl 18 - -let withalt mask = mask land metamask != 0 - -let withctrl mask = mask land ctrlmask != 0 - -let withshift mask = mask land shiftmask != 0 - -let withmeta mask = mask land metamask != 0 - -let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0 - -let xlatt, xlatf = - let t = Hashtbl.create 20 - and f = Hashtbl.create 20 in - let add n nl k = - List.iter (fun s -> Hashtbl.add t s k) (n::nl); - Hashtbl.add f k n - in - let addc c = - let s = String.make 1 c in - add s [] (Char.code c) - in - let addcr a b = - let an = Char.code a and bn = Char.code b in - for i = an to bn do addc (Char.chr i) done; - in - addcr '0' '9'; - addcr 'a' 'z'; - addcr 'A' 'Z'; - String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?"; - for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xf704 + i) done; - add "space" [] 32; - add "ret" ["return"; "enter"] 13; - add "tab" [] 9; - add "left" [] 0xff51; - add "right" [] 0xff53; - add "home" [] 0xf729; - add "end" [] 0xf72b; - add "ins" ["insert"] 0xf729; - add "del" ["delete"] 0x7f; - add "esc" ["escape"] 27; - add "pgup" ["pageup"] 0xf72c; - add "pgdown" ["pagedown"; "pgdn"] 0xf72d; - add "backspace" [] 8; - add "up" [] 0xf700; - add "down" [] 0xf701; - (* add "menu" [] 0xff67; *) (* ? *) - t, f - -let keyname k = - try Hashtbl.find xlatf k - with Not_found -> Printf.sprintf "%#x" k - -let namekey name = - try Hashtbl.find xlatt name - with Not_found -> - if String.length name = 1 - then Char.code name.[0] - else int_of_string name - -let ks2kt = - let open Keys in - function - | 8 -> Backspace - | 27 -> Escape - | 13 -> Enter - | 0xf727 -> Insert - | 0xf729 | 0xfff04 -> Home - | 0xf702 | 0xfff05 -> Left - | 0xfff0b | 0xf700 -> Up - | 0xfff0a | 0xF703 -> Right - | 0xfff01 | 0xf701-> Down - | 0xfff09 | 0xf72c -> Prior - | 0xf72d | 0xfff07 -> Next - | 0xfff02 | 0xf72b -> End - | 0x7f -> Delete - | 0xfff03 -> Enter - | 0xfff08 -> Ascii '+' - | 0xfff06 -> Ascii '-' - | code when code > 31 && code < 128 -> Ascii (Char.unsafe_chr code) - | code when code >= 0xffb0 && code <= 0xffb9 -> - Ascii (Char.unsafe_chr (code - 0xffb0 + 0x30)) - | code when code >= 0xf704 && code <= 0xf70f -> Fn (code - 0xf704 + 1) - | code when code land 0xff00 = 0xff00 -> Ctrl code - | code -> Code code - -type keycode = int -let cAp = "pbcopy and pbpaste" diff --git a/wsi/x11/keysym2ucs.c b/wsi/x11/keysym2ucs.c deleted file mode 100644 index e2cb36f..0000000 --- a/wsi/x11/keysym2ucs.c +++ /dev/null @@ -1,849 +0,0 @@ -/* This is a (despite a fat warning) slightly modified: - www.cl.cam.ac.uk/~mgk25/ucs/keysym2ucs.c - by Markus G. Kuhn */ -/* $XFree86$ - * This module converts keysym values into the corresponding ISO 10646 - * (UCS, Unicode) values. - * - * The array keysymtab[] contains pairs of X11 keysym values for graphical - * characters and the corresponding Unicode value. The function - * keysym2ucs() maps a keysym onto a Unicode value using a binary search, - * therefore keysymtab[] must remain SORTED by keysym value. - * - * The keysym -> UTF-8 conversion will hopefully one day be provided - * by Xlib via XmbLookupString() and should ideally not have to be - * done in X applications. But we are not there yet. - * - * We allow to represent any UCS character in the range U-00000000 to - * U-00FFFFFF by a keysym value in the range 0x01000000 to 0x01ffffff. - * This admittedly does not cover the entire 31-bit space of UCS, but - * it does cover all of the characters up to U-10FFFF, which can be - * represented by UTF-16, and more, and it is very unlikely that higher - * UCS codes will ever be assigned by ISO. So to get Unicode character - * U+ABCD you can directly use keysym 0x0100abcd. - * - * NOTE: The comments in the table below contain the actual character - * encoded in UTF-8, so for viewing and editing best use an editor in - * UTF-8 mode. - * - * Author: Markus G. Kuhn , - * University of Cambridge, April 2001 - * - * Special thanks to Richard Verhoeven for preparing - * an initial draft of the mapping table. - * - * This software is in the public domain. Share and enjoy! - * - * AUTOMATICALLY GENERATED FILE, DO NOT EDIT !!! (unicode/convmap.pl) - */ - -struct codepair { - unsigned short keysym; - unsigned short ucs; -} keysymtab[] = { - { 0x01a1, 0x0104 }, /* Aogonek Ą LATIN CAPITAL LETTER A WITH OGONEK */ - { 0x01a2, 0x02d8 }, /* breve ˘ BREVE */ - { 0x01a3, 0x0141 }, /* Lstroke Ł LATIN CAPITAL LETTER L WITH STROKE */ - { 0x01a5, 0x013d }, /* Lcaron Ľ LATIN CAPITAL LETTER L WITH CARON */ - { 0x01a6, 0x015a }, /* Sacute Ś LATIN CAPITAL LETTER S WITH ACUTE */ - { 0x01a9, 0x0160 }, /* Scaron Š LATIN CAPITAL LETTER S WITH CARON */ - { 0x01aa, 0x015e }, /* Scedilla Ş LATIN CAPITAL LETTER S WITH CEDILLA */ - { 0x01ab, 0x0164 }, /* Tcaron Ť LATIN CAPITAL LETTER T WITH CARON */ - { 0x01ac, 0x0179 }, /* Zacute Ź LATIN CAPITAL LETTER Z WITH ACUTE */ - { 0x01ae, 0x017d }, /* Zcaron Ž LATIN CAPITAL LETTER Z WITH CARON */ - { 0x01af, 0x017b }, /* Zabovedot Ż LATIN CAPITAL LETTER Z WITH DOT ABOVE */ - { 0x01b1, 0x0105 }, /* aogonek ą LATIN SMALL LETTER A WITH OGONEK */ - { 0x01b2, 0x02db }, /* ogonek ˛ OGONEK */ - { 0x01b3, 0x0142 }, /* lstroke ł LATIN SMALL LETTER L WITH STROKE */ - { 0x01b5, 0x013e }, /* lcaron ľ LATIN SMALL LETTER L WITH CARON */ - { 0x01b6, 0x015b }, /* sacute ś LATIN SMALL LETTER S WITH ACUTE */ - { 0x01b7, 0x02c7 }, /* caron ˇ CARON */ - { 0x01b9, 0x0161 }, /* scaron š LATIN SMALL LETTER S WITH CARON */ - { 0x01ba, 0x015f }, /* scedilla ş LATIN SMALL LETTER S WITH CEDILLA */ - { 0x01bb, 0x0165 }, /* tcaron ť LATIN SMALL LETTER T WITH CARON */ - { 0x01bc, 0x017a }, /* zacute ź LATIN SMALL LETTER Z WITH ACUTE */ - { 0x01bd, 0x02dd }, /* doubleacute ˝ DOUBLE ACUTE ACCENT */ - { 0x01be, 0x017e }, /* zcaron ž LATIN SMALL LETTER Z WITH CARON */ - { 0x01bf, 0x017c }, /* zabovedot ż LATIN SMALL LETTER Z WITH DOT ABOVE */ - { 0x01c0, 0x0154 }, /* Racute Ŕ LATIN CAPITAL LETTER R WITH ACUTE */ - { 0x01c3, 0x0102 }, /* Abreve Ă LATIN CAPITAL LETTER A WITH BREVE */ - { 0x01c5, 0x0139 }, /* Lacute Ĺ LATIN CAPITAL LETTER L WITH ACUTE */ - { 0x01c6, 0x0106 }, /* Cacute Ć LATIN CAPITAL LETTER C WITH ACUTE */ - { 0x01c8, 0x010c }, /* Ccaron Č LATIN CAPITAL LETTER C WITH CARON */ - { 0x01ca, 0x0118 }, /* Eogonek Ę LATIN CAPITAL LETTER E WITH OGONEK */ - { 0x01cc, 0x011a }, /* Ecaron Ě LATIN CAPITAL LETTER E WITH CARON */ - { 0x01cf, 0x010e }, /* Dcaron Ď LATIN CAPITAL LETTER D WITH CARON */ - { 0x01d0, 0x0110 }, /* Dstroke Đ LATIN CAPITAL LETTER D WITH STROKE */ - { 0x01d1, 0x0143 }, /* Nacute Ń LATIN CAPITAL LETTER N WITH ACUTE */ - { 0x01d2, 0x0147 }, /* Ncaron Ň LATIN CAPITAL LETTER N WITH CARON */ - { 0x01d5, 0x0150 }, /* Odoubleacute Ő LATIN CAPITAL LETTER O WITH DOUBLE ACUTE */ - { 0x01d8, 0x0158 }, /* Rcaron Ř LATIN CAPITAL LETTER R WITH CARON */ - { 0x01d9, 0x016e }, /* Uring Ů LATIN CAPITAL LETTER U WITH RING ABOVE */ - { 0x01db, 0x0170 }, /* Udoubleacute Ű LATIN CAPITAL LETTER U WITH DOUBLE ACUTE */ - { 0x01de, 0x0162 }, /* Tcedilla Ţ LATIN CAPITAL LETTER T WITH CEDILLA */ - { 0x01e0, 0x0155 }, /* racute ŕ LATIN SMALL LETTER R WITH ACUTE */ - { 0x01e3, 0x0103 }, /* abreve ă LATIN SMALL LETTER A WITH BREVE */ - { 0x01e5, 0x013a }, /* lacute ĺ LATIN SMALL LETTER L WITH ACUTE */ - { 0x01e6, 0x0107 }, /* cacute ć LATIN SMALL LETTER C WITH ACUTE */ - { 0x01e8, 0x010d }, /* ccaron č LATIN SMALL LETTER C WITH CARON */ - { 0x01ea, 0x0119 }, /* eogonek ę LATIN SMALL LETTER E WITH OGONEK */ - { 0x01ec, 0x011b }, /* ecaron ě LATIN SMALL LETTER E WITH CARON */ - { 0x01ef, 0x010f }, /* dcaron ď LATIN SMALL LETTER D WITH CARON */ - { 0x01f0, 0x0111 }, /* dstroke đ LATIN SMALL LETTER D WITH STROKE */ - { 0x01f1, 0x0144 }, /* nacute ń LATIN SMALL LETTER N WITH ACUTE */ - { 0x01f2, 0x0148 }, /* ncaron ň LATIN SMALL LETTER N WITH CARON */ - { 0x01f5, 0x0151 }, /* odoubleacute ő LATIN SMALL LETTER O WITH DOUBLE ACUTE */ - { 0x01f8, 0x0159 }, /* rcaron ř LATIN SMALL LETTER R WITH CARON */ - { 0x01f9, 0x016f }, /* uring ů LATIN SMALL LETTER U WITH RING ABOVE */ - { 0x01fb, 0x0171 }, /* udoubleacute ű LATIN SMALL LETTER U WITH DOUBLE ACUTE */ - { 0x01fe, 0x0163 }, /* tcedilla ţ LATIN SMALL LETTER T WITH CEDILLA */ - { 0x01ff, 0x02d9 }, /* abovedot ˙ DOT ABOVE */ - { 0x02a1, 0x0126 }, /* Hstroke Ħ LATIN CAPITAL LETTER H WITH STROKE */ - { 0x02a6, 0x0124 }, /* Hcircumflex Ĥ LATIN CAPITAL LETTER H WITH CIRCUMFLEX */ - { 0x02a9, 0x0130 }, /* Iabovedot İ LATIN CAPITAL LETTER I WITH DOT ABOVE */ - { 0x02ab, 0x011e }, /* Gbreve Ğ LATIN CAPITAL LETTER G WITH BREVE */ - { 0x02ac, 0x0134 }, /* Jcircumflex Ĵ LATIN CAPITAL LETTER J WITH CIRCUMFLEX */ - { 0x02b1, 0x0127 }, /* hstroke ħ LATIN SMALL LETTER H WITH STROKE */ - { 0x02b6, 0x0125 }, /* hcircumflex ĥ LATIN SMALL LETTER H WITH CIRCUMFLEX */ - { 0x02b9, 0x0131 }, /* idotless ı LATIN SMALL LETTER DOTLESS I */ - { 0x02bb, 0x011f }, /* gbreve ğ LATIN SMALL LETTER G WITH BREVE */ - { 0x02bc, 0x0135 }, /* jcircumflex ĵ LATIN SMALL LETTER J WITH CIRCUMFLEX */ - { 0x02c5, 0x010a }, /* Cabovedot Ċ LATIN CAPITAL LETTER C WITH DOT ABOVE */ - { 0x02c6, 0x0108 }, /* Ccircumflex Ĉ LATIN CAPITAL LETTER C WITH CIRCUMFLEX */ - { 0x02d5, 0x0120 }, /* Gabovedot Ġ LATIN CAPITAL LETTER G WITH DOT ABOVE */ - { 0x02d8, 0x011c }, /* Gcircumflex Ĝ LATIN CAPITAL LETTER G WITH CIRCUMFLEX */ - { 0x02dd, 0x016c }, /* Ubreve Ŭ LATIN CAPITAL LETTER U WITH BREVE */ - { 0x02de, 0x015c }, /* Scircumflex Ŝ LATIN CAPITAL LETTER S WITH CIRCUMFLEX */ - { 0x02e5, 0x010b }, /* cabovedot ċ LATIN SMALL LETTER C WITH DOT ABOVE */ - { 0x02e6, 0x0109 }, /* ccircumflex ĉ LATIN SMALL LETTER C WITH CIRCUMFLEX */ - { 0x02f5, 0x0121 }, /* gabovedot ġ LATIN SMALL LETTER G WITH DOT ABOVE */ - { 0x02f8, 0x011d }, /* gcircumflex ĝ LATIN SMALL LETTER G WITH CIRCUMFLEX */ - { 0x02fd, 0x016d }, /* ubreve ŭ LATIN SMALL LETTER U WITH BREVE */ - { 0x02fe, 0x015d }, /* scircumflex ŝ LATIN SMALL LETTER S WITH CIRCUMFLEX */ - { 0x03a2, 0x0138 }, /* kra ĸ LATIN SMALL LETTER KRA */ - { 0x03a3, 0x0156 }, /* Rcedilla Ŗ LATIN CAPITAL LETTER R WITH CEDILLA */ - { 0x03a5, 0x0128 }, /* Itilde Ĩ LATIN CAPITAL LETTER I WITH TILDE */ - { 0x03a6, 0x013b }, /* Lcedilla Ļ LATIN CAPITAL LETTER L WITH CEDILLA */ - { 0x03aa, 0x0112 }, /* Emacron Ē LATIN CAPITAL LETTER E WITH MACRON */ - { 0x03ab, 0x0122 }, /* Gcedilla Ģ LATIN CAPITAL LETTER G WITH CEDILLA */ - { 0x03ac, 0x0166 }, /* Tslash Ŧ LATIN CAPITAL LETTER T WITH STROKE */ - { 0x03b3, 0x0157 }, /* rcedilla ŗ LATIN SMALL LETTER R WITH CEDILLA */ - { 0x03b5, 0x0129 }, /* itilde ĩ LATIN SMALL LETTER I WITH TILDE */ - { 0x03b6, 0x013c }, /* lcedilla ļ LATIN SMALL LETTER L WITH CEDILLA */ - { 0x03ba, 0x0113 }, /* emacron ē LATIN SMALL LETTER E WITH MACRON */ - { 0x03bb, 0x0123 }, /* gcedilla ģ LATIN SMALL LETTER G WITH CEDILLA */ - { 0x03bc, 0x0167 }, /* tslash ŧ LATIN SMALL LETTER T WITH STROKE */ - { 0x03bd, 0x014a }, /* ENG Ŋ LATIN CAPITAL LETTER ENG */ - { 0x03bf, 0x014b }, /* eng ŋ LATIN SMALL LETTER ENG */ - { 0x03c0, 0x0100 }, /* Amacron Ā LATIN CAPITAL LETTER A WITH MACRON */ - { 0x03c7, 0x012e }, /* Iogonek Į LATIN CAPITAL LETTER I WITH OGONEK */ - { 0x03cc, 0x0116 }, /* Eabovedot Ė LATIN CAPITAL LETTER E WITH DOT ABOVE */ - { 0x03cf, 0x012a }, /* Imacron Ī LATIN CAPITAL LETTER I WITH MACRON */ - { 0x03d1, 0x0145 }, /* Ncedilla Ņ LATIN CAPITAL LETTER N WITH CEDILLA */ - { 0x03d2, 0x014c }, /* Omacron Ō LATIN CAPITAL LETTER O WITH MACRON */ - { 0x03d3, 0x0136 }, /* Kcedilla Ķ LATIN CAPITAL LETTER K WITH CEDILLA */ - { 0x03d9, 0x0172 }, /* Uogonek Ų LATIN CAPITAL LETTER U WITH OGONEK */ - { 0x03dd, 0x0168 }, /* Utilde Ũ LATIN CAPITAL LETTER U WITH TILDE */ - { 0x03de, 0x016a }, /* Umacron Ū LATIN CAPITAL LETTER U WITH MACRON */ - { 0x03e0, 0x0101 }, /* amacron ā LATIN SMALL LETTER A WITH MACRON */ - { 0x03e7, 0x012f }, /* iogonek į LATIN SMALL LETTER I WITH OGONEK */ - { 0x03ec, 0x0117 }, /* eabovedot ė LATIN SMALL LETTER E WITH DOT ABOVE */ - { 0x03ef, 0x012b }, /* imacron ī LATIN SMALL LETTER I WITH MACRON */ - { 0x03f1, 0x0146 }, /* ncedilla ņ LATIN SMALL LETTER N WITH CEDILLA */ - { 0x03f2, 0x014d }, /* omacron ō LATIN SMALL LETTER O WITH MACRON */ - { 0x03f3, 0x0137 }, /* kcedilla ķ LATIN SMALL LETTER K WITH CEDILLA */ - { 0x03f9, 0x0173 }, /* uogonek ų LATIN SMALL LETTER U WITH OGONEK */ - { 0x03fd, 0x0169 }, /* utilde ũ LATIN SMALL LETTER U WITH TILDE */ - { 0x03fe, 0x016b }, /* umacron ū LATIN SMALL LETTER U WITH MACRON */ - { 0x047e, 0x203e }, /* overline ‾ OVERLINE */ - { 0x04a1, 0x3002 }, /* kana_fullstop 。 IDEOGRAPHIC FULL STOP */ - { 0x04a2, 0x300c }, /* kana_openingbracket 「 LEFT CORNER BRACKET */ - { 0x04a3, 0x300d }, /* kana_closingbracket 」 RIGHT CORNER BRACKET */ - { 0x04a4, 0x3001 }, /* kana_comma 、 IDEOGRAPHIC COMMA */ - { 0x04a5, 0x30fb }, /* kana_conjunctive ・ KATAKANA MIDDLE DOT */ - { 0x04a6, 0x30f2 }, /* kana_WO ヲ KATAKANA LETTER WO */ - { 0x04a7, 0x30a1 }, /* kana_a ァ KATAKANA LETTER SMALL A */ - { 0x04a8, 0x30a3 }, /* kana_i ィ KATAKANA LETTER SMALL I */ - { 0x04a9, 0x30a5 }, /* kana_u ゥ KATAKANA LETTER SMALL U */ - { 0x04aa, 0x30a7 }, /* kana_e ェ KATAKANA LETTER SMALL E */ - { 0x04ab, 0x30a9 }, /* kana_o ォ KATAKANA LETTER SMALL O */ - { 0x04ac, 0x30e3 }, /* kana_ya ャ KATAKANA LETTER SMALL YA */ - { 0x04ad, 0x30e5 }, /* kana_yu ュ KATAKANA LETTER SMALL YU */ - { 0x04ae, 0x30e7 }, /* kana_yo ョ KATAKANA LETTER SMALL YO */ - { 0x04af, 0x30c3 }, /* kana_tsu ッ KATAKANA LETTER SMALL TU */ - { 0x04b0, 0x30fc }, /* prolongedsound ー KATAKANA-HIRAGANA PROLONGED SOUND MARK */ - { 0x04b1, 0x30a2 }, /* kana_A ア KATAKANA LETTER A */ - { 0x04b2, 0x30a4 }, /* kana_I イ KATAKANA LETTER I */ - { 0x04b3, 0x30a6 }, /* kana_U ウ KATAKANA LETTER U */ - { 0x04b4, 0x30a8 }, /* kana_E エ KATAKANA LETTER E */ - { 0x04b5, 0x30aa }, /* kana_O オ KATAKANA LETTER O */ - { 0x04b6, 0x30ab }, /* kana_KA カ KATAKANA LETTER KA */ - { 0x04b7, 0x30ad }, /* kana_KI キ KATAKANA LETTER KI */ - { 0x04b8, 0x30af }, /* kana_KU ク KATAKANA LETTER KU */ - { 0x04b9, 0x30b1 }, /* kana_KE ケ KATAKANA LETTER KE */ - { 0x04ba, 0x30b3 }, /* kana_KO コ KATAKANA LETTER KO */ - { 0x04bb, 0x30b5 }, /* kana_SA サ KATAKANA LETTER SA */ - { 0x04bc, 0x30b7 }, /* kana_SHI シ KATAKANA LETTER SI */ - { 0x04bd, 0x30b9 }, /* kana_SU ス KATAKANA LETTER SU */ - { 0x04be, 0x30bb }, /* kana_SE セ KATAKANA LETTER SE */ - { 0x04bf, 0x30bd }, /* kana_SO ソ KATAKANA LETTER SO */ - { 0x04c0, 0x30bf }, /* kana_TA タ KATAKANA LETTER TA */ - { 0x04c1, 0x30c1 }, /* kana_CHI チ KATAKANA LETTER TI */ - { 0x04c2, 0x30c4 }, /* kana_TSU ツ KATAKANA LETTER TU */ - { 0x04c3, 0x30c6 }, /* kana_TE テ KATAKANA LETTER TE */ - { 0x04c4, 0x30c8 }, /* kana_TO ト KATAKANA LETTER TO */ - { 0x04c5, 0x30ca }, /* kana_NA ナ KATAKANA LETTER NA */ - { 0x04c6, 0x30cb }, /* kana_NI ニ KATAKANA LETTER NI */ - { 0x04c7, 0x30cc }, /* kana_NU ヌ KATAKANA LETTER NU */ - { 0x04c8, 0x30cd }, /* kana_NE ネ KATAKANA LETTER NE */ - { 0x04c9, 0x30ce }, /* kana_NO ノ KATAKANA LETTER NO */ - { 0x04ca, 0x30cf }, /* kana_HA ハ KATAKANA LETTER HA */ - { 0x04cb, 0x30d2 }, /* kana_HI ヒ KATAKANA LETTER HI */ - { 0x04cc, 0x30d5 }, /* kana_FU フ KATAKANA LETTER HU */ - { 0x04cd, 0x30d8 }, /* kana_HE ヘ KATAKANA LETTER HE */ - { 0x04ce, 0x30db }, /* kana_HO ホ KATAKANA LETTER HO */ - { 0x04cf, 0x30de }, /* kana_MA マ KATAKANA LETTER MA */ - { 0x04d0, 0x30df }, /* kana_MI ミ KATAKANA LETTER MI */ - { 0x04d1, 0x30e0 }, /* kana_MU ム KATAKANA LETTER MU */ - { 0x04d2, 0x30e1 }, /* kana_ME メ KATAKANA LETTER ME */ - { 0x04d3, 0x30e2 }, /* kana_MO モ KATAKANA LETTER MO */ - { 0x04d4, 0x30e4 }, /* kana_YA ヤ KATAKANA LETTER YA */ - { 0x04d5, 0x30e6 }, /* kana_YU ユ KATAKANA LETTER YU */ - { 0x04d6, 0x30e8 }, /* kana_YO ヨ KATAKANA LETTER YO */ - { 0x04d7, 0x30e9 }, /* kana_RA ラ KATAKANA LETTER RA */ - { 0x04d8, 0x30ea }, /* kana_RI リ KATAKANA LETTER RI */ - { 0x04d9, 0x30eb }, /* kana_RU ル KATAKANA LETTER RU */ - { 0x04da, 0x30ec }, /* kana_RE レ KATAKANA LETTER RE */ - { 0x04db, 0x30ed }, /* kana_RO ロ KATAKANA LETTER RO */ - { 0x04dc, 0x30ef }, /* kana_WA ワ KATAKANA LETTER WA */ - { 0x04dd, 0x30f3 }, /* kana_N ン KATAKANA LETTER N */ - { 0x04de, 0x309b }, /* voicedsound ゛ KATAKANA-HIRAGANA VOICED SOUND MARK */ - { 0x04df, 0x309c }, /* semivoicedsound ゜ KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK */ - { 0x05ac, 0x060c }, /* Arabic_comma ، ARABIC COMMA */ - { 0x05bb, 0x061b }, /* Arabic_semicolon ؛ ARABIC SEMICOLON */ - { 0x05bf, 0x061f }, /* Arabic_question_mark ؟ ARABIC QUESTION MARK */ - { 0x05c1, 0x0621 }, /* Arabic_hamza ء ARABIC LETTER HAMZA */ - { 0x05c2, 0x0622 }, /* Arabic_maddaonalef آ ARABIC LETTER ALEF WITH MADDA ABOVE */ - { 0x05c3, 0x0623 }, /* Arabic_hamzaonalef أ ARABIC LETTER ALEF WITH HAMZA ABOVE */ - { 0x05c4, 0x0624 }, /* Arabic_hamzaonwaw ؤ ARABIC LETTER WAW WITH HAMZA ABOVE */ - { 0x05c5, 0x0625 }, /* Arabic_hamzaunderalef إ ARABIC LETTER ALEF WITH HAMZA BELOW */ - { 0x05c6, 0x0626 }, /* Arabic_hamzaonyeh ئ ARABIC LETTER YEH WITH HAMZA ABOVE */ - { 0x05c7, 0x0627 }, /* Arabic_alef ا ARABIC LETTER ALEF */ - { 0x05c8, 0x0628 }, /* Arabic_beh ب ARABIC LETTER BEH */ - { 0x05c9, 0x0629 }, /* Arabic_tehmarbuta ة ARABIC LETTER TEH MARBUTA */ - { 0x05ca, 0x062a }, /* Arabic_teh ت ARABIC LETTER TEH */ - { 0x05cb, 0x062b }, /* Arabic_theh ث ARABIC LETTER THEH */ - { 0x05cc, 0x062c }, /* Arabic_jeem ج ARABIC LETTER JEEM */ - { 0x05cd, 0x062d }, /* Arabic_hah ح ARABIC LETTER HAH */ - { 0x05ce, 0x062e }, /* Arabic_khah خ ARABIC LETTER KHAH */ - { 0x05cf, 0x062f }, /* Arabic_dal د ARABIC LETTER DAL */ - { 0x05d0, 0x0630 }, /* Arabic_thal ذ ARABIC LETTER THAL */ - { 0x05d1, 0x0631 }, /* Arabic_ra ر ARABIC LETTER REH */ - { 0x05d2, 0x0632 }, /* Arabic_zain ز ARABIC LETTER ZAIN */ - { 0x05d3, 0x0633 }, /* Arabic_seen س ARABIC LETTER SEEN */ - { 0x05d4, 0x0634 }, /* Arabic_sheen ش ARABIC LETTER SHEEN */ - { 0x05d5, 0x0635 }, /* Arabic_sad ص ARABIC LETTER SAD */ - { 0x05d6, 0x0636 }, /* Arabic_dad ض ARABIC LETTER DAD */ - { 0x05d7, 0x0637 }, /* Arabic_tah ط ARABIC LETTER TAH */ - { 0x05d8, 0x0638 }, /* Arabic_zah ظ ARABIC LETTER ZAH */ - { 0x05d9, 0x0639 }, /* Arabic_ain ع ARABIC LETTER AIN */ - { 0x05da, 0x063a }, /* Arabic_ghain غ ARABIC LETTER GHAIN */ - { 0x05e0, 0x0640 }, /* Arabic_tatweel ـ ARABIC TATWEEL */ - { 0x05e1, 0x0641 }, /* Arabic_feh ف ARABIC LETTER FEH */ - { 0x05e2, 0x0642 }, /* Arabic_qaf ق ARABIC LETTER QAF */ - { 0x05e3, 0x0643 }, /* Arabic_kaf ك ARABIC LETTER KAF */ - { 0x05e4, 0x0644 }, /* Arabic_lam ل ARABIC LETTER LAM */ - { 0x05e5, 0x0645 }, /* Arabic_meem م ARABIC LETTER MEEM */ - { 0x05e6, 0x0646 }, /* Arabic_noon ن ARABIC LETTER NOON */ - { 0x05e7, 0x0647 }, /* Arabic_ha ه ARABIC LETTER HEH */ - { 0x05e8, 0x0648 }, /* Arabic_waw و ARABIC LETTER WAW */ - { 0x05e9, 0x0649 }, /* Arabic_alefmaksura ى ARABIC LETTER ALEF MAKSURA */ - { 0x05ea, 0x064a }, /* Arabic_yeh ي ARABIC LETTER YEH */ - { 0x05eb, 0x064b }, /* Arabic_fathatan ً ARABIC FATHATAN */ - { 0x05ec, 0x064c }, /* Arabic_dammatan ٌ ARABIC DAMMATAN */ - { 0x05ed, 0x064d }, /* Arabic_kasratan ٍ ARABIC KASRATAN */ - { 0x05ee, 0x064e }, /* Arabic_fatha َ ARABIC FATHA */ - { 0x05ef, 0x064f }, /* Arabic_damma ُ ARABIC DAMMA */ - { 0x05f0, 0x0650 }, /* Arabic_kasra ِ ARABIC KASRA */ - { 0x05f1, 0x0651 }, /* Arabic_shadda ّ ARABIC SHADDA */ - { 0x05f2, 0x0652 }, /* Arabic_sukun ْ ARABIC SUKUN */ - { 0x06a1, 0x0452 }, /* Serbian_dje ђ CYRILLIC SMALL LETTER DJE */ - { 0x06a2, 0x0453 }, /* Macedonia_gje ѓ CYRILLIC SMALL LETTER GJE */ - { 0x06a3, 0x0451 }, /* Cyrillic_io ё CYRILLIC SMALL LETTER IO */ - { 0x06a4, 0x0454 }, /* Ukrainian_ie є CYRILLIC SMALL LETTER UKRAINIAN IE */ - { 0x06a5, 0x0455 }, /* Macedonia_dse ѕ CYRILLIC SMALL LETTER DZE */ - { 0x06a6, 0x0456 }, /* Ukrainian_i і CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I */ - { 0x06a7, 0x0457 }, /* Ukrainian_yi ї CYRILLIC SMALL LETTER YI */ - { 0x06a8, 0x0458 }, /* Cyrillic_je ј CYRILLIC SMALL LETTER JE */ - { 0x06a9, 0x0459 }, /* Cyrillic_lje љ CYRILLIC SMALL LETTER LJE */ - { 0x06aa, 0x045a }, /* Cyrillic_nje њ CYRILLIC SMALL LETTER NJE */ - { 0x06ab, 0x045b }, /* Serbian_tshe ћ CYRILLIC SMALL LETTER TSHE */ - { 0x06ac, 0x045c }, /* Macedonia_kje ќ CYRILLIC SMALL LETTER KJE */ - { 0x06ae, 0x045e }, /* Byelorussian_shortu ў CYRILLIC SMALL LETTER SHORT U */ - { 0x06af, 0x045f }, /* Cyrillic_dzhe џ CYRILLIC SMALL LETTER DZHE */ - { 0x06b0, 0x2116 }, /* numerosign № NUMERO SIGN */ - { 0x06b1, 0x0402 }, /* Serbian_DJE Ђ CYRILLIC CAPITAL LETTER DJE */ - { 0x06b2, 0x0403 }, /* Macedonia_GJE Ѓ CYRILLIC CAPITAL LETTER GJE */ - { 0x06b3, 0x0401 }, /* Cyrillic_IO Ё CYRILLIC CAPITAL LETTER IO */ - { 0x06b4, 0x0404 }, /* Ukrainian_IE Є CYRILLIC CAPITAL LETTER UKRAINIAN IE */ - { 0x06b5, 0x0405 }, /* Macedonia_DSE Ѕ CYRILLIC CAPITAL LETTER DZE */ - { 0x06b6, 0x0406 }, /* Ukrainian_I І CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I */ - { 0x06b7, 0x0407 }, /* Ukrainian_YI Ї CYRILLIC CAPITAL LETTER YI */ - { 0x06b8, 0x0408 }, /* Cyrillic_JE Ј CYRILLIC CAPITAL LETTER JE */ - { 0x06b9, 0x0409 }, /* Cyrillic_LJE Љ CYRILLIC CAPITAL LETTER LJE */ - { 0x06ba, 0x040a }, /* Cyrillic_NJE Њ CYRILLIC CAPITAL LETTER NJE */ - { 0x06bb, 0x040b }, /* Serbian_TSHE Ћ CYRILLIC CAPITAL LETTER TSHE */ - { 0x06bc, 0x040c }, /* Macedonia_KJE Ќ CYRILLIC CAPITAL LETTER KJE */ - { 0x06be, 0x040e }, /* Byelorussian_SHORTU Ў CYRILLIC CAPITAL LETTER SHORT U */ - { 0x06bf, 0x040f }, /* Cyrillic_DZHE Џ CYRILLIC CAPITAL LETTER DZHE */ - { 0x06c0, 0x044e }, /* Cyrillic_yu ю CYRILLIC SMALL LETTER YU */ - { 0x06c1, 0x0430 }, /* Cyrillic_a а CYRILLIC SMALL LETTER A */ - { 0x06c2, 0x0431 }, /* Cyrillic_be б CYRILLIC SMALL LETTER BE */ - { 0x06c3, 0x0446 }, /* Cyrillic_tse ц CYRILLIC SMALL LETTER TSE */ - { 0x06c4, 0x0434 }, /* Cyrillic_de д CYRILLIC SMALL LETTER DE */ - { 0x06c5, 0x0435 }, /* Cyrillic_ie е CYRILLIC SMALL LETTER IE */ - { 0x06c6, 0x0444 }, /* Cyrillic_ef ф CYRILLIC SMALL LETTER EF */ - { 0x06c7, 0x0433 }, /* Cyrillic_ghe г CYRILLIC SMALL LETTER GHE */ - { 0x06c8, 0x0445 }, /* Cyrillic_ha х CYRILLIC SMALL LETTER HA */ - { 0x06c9, 0x0438 }, /* Cyrillic_i и CYRILLIC SMALL LETTER I */ - { 0x06ca, 0x0439 }, /* Cyrillic_shorti й CYRILLIC SMALL LETTER SHORT I */ - { 0x06cb, 0x043a }, /* Cyrillic_ka к CYRILLIC SMALL LETTER KA */ - { 0x06cc, 0x043b }, /* Cyrillic_el л CYRILLIC SMALL LETTER EL */ - { 0x06cd, 0x043c }, /* Cyrillic_em м CYRILLIC SMALL LETTER EM */ - { 0x06ce, 0x043d }, /* Cyrillic_en н CYRILLIC SMALL LETTER EN */ - { 0x06cf, 0x043e }, /* Cyrillic_o о CYRILLIC SMALL LETTER O */ - { 0x06d0, 0x043f }, /* Cyrillic_pe п CYRILLIC SMALL LETTER PE */ - { 0x06d1, 0x044f }, /* Cyrillic_ya я CYRILLIC SMALL LETTER YA */ - { 0x06d2, 0x0440 }, /* Cyrillic_er р CYRILLIC SMALL LETTER ER */ - { 0x06d3, 0x0441 }, /* Cyrillic_es с CYRILLIC SMALL LETTER ES */ - { 0x06d4, 0x0442 }, /* Cyrillic_te т CYRILLIC SMALL LETTER TE */ - { 0x06d5, 0x0443 }, /* Cyrillic_u у CYRILLIC SMALL LETTER U */ - { 0x06d6, 0x0436 }, /* Cyrillic_zhe ж CYRILLIC SMALL LETTER ZHE */ - { 0x06d7, 0x0432 }, /* Cyrillic_ve в CYRILLIC SMALL LETTER VE */ - { 0x06d8, 0x044c }, /* Cyrillic_softsign ь CYRILLIC SMALL LETTER SOFT SIGN */ - { 0x06d9, 0x044b }, /* Cyrillic_yeru ы CYRILLIC SMALL LETTER YERU */ - { 0x06da, 0x0437 }, /* Cyrillic_ze з CYRILLIC SMALL LETTER ZE */ - { 0x06db, 0x0448 }, /* Cyrillic_sha ш CYRILLIC SMALL LETTER SHA */ - { 0x06dc, 0x044d }, /* Cyrillic_e э CYRILLIC SMALL LETTER E */ - { 0x06dd, 0x0449 }, /* Cyrillic_shcha щ CYRILLIC SMALL LETTER SHCHA */ - { 0x06de, 0x0447 }, /* Cyrillic_che ч CYRILLIC SMALL LETTER CHE */ - { 0x06df, 0x044a }, /* Cyrillic_hardsign ъ CYRILLIC SMALL LETTER HARD SIGN */ - { 0x06e0, 0x042e }, /* Cyrillic_YU Ю CYRILLIC CAPITAL LETTER YU */ - { 0x06e1, 0x0410 }, /* Cyrillic_A А CYRILLIC CAPITAL LETTER A */ - { 0x06e2, 0x0411 }, /* Cyrillic_BE Б CYRILLIC CAPITAL LETTER BE */ - { 0x06e3, 0x0426 }, /* Cyrillic_TSE Ц CYRILLIC CAPITAL LETTER TSE */ - { 0x06e4, 0x0414 }, /* Cyrillic_DE Д CYRILLIC CAPITAL LETTER DE */ - { 0x06e5, 0x0415 }, /* Cyrillic_IE Е CYRILLIC CAPITAL LETTER IE */ - { 0x06e6, 0x0424 }, /* Cyrillic_EF Ф CYRILLIC CAPITAL LETTER EF */ - { 0x06e7, 0x0413 }, /* Cyrillic_GHE Г CYRILLIC CAPITAL LETTER GHE */ - { 0x06e8, 0x0425 }, /* Cyrillic_HA Х CYRILLIC CAPITAL LETTER HA */ - { 0x06e9, 0x0418 }, /* Cyrillic_I И CYRILLIC CAPITAL LETTER I */ - { 0x06ea, 0x0419 }, /* Cyrillic_SHORTI Й CYRILLIC CAPITAL LETTER SHORT I */ - { 0x06eb, 0x041a }, /* Cyrillic_KA К CYRILLIC CAPITAL LETTER KA */ - { 0x06ec, 0x041b }, /* Cyrillic_EL Л CYRILLIC CAPITAL LETTER EL */ - { 0x06ed, 0x041c }, /* Cyrillic_EM М CYRILLIC CAPITAL LETTER EM */ - { 0x06ee, 0x041d }, /* Cyrillic_EN Н CYRILLIC CAPITAL LETTER EN */ - { 0x06ef, 0x041e }, /* Cyrillic_O О CYRILLIC CAPITAL LETTER O */ - { 0x06f0, 0x041f }, /* Cyrillic_PE П CYRILLIC CAPITAL LETTER PE */ - { 0x06f1, 0x042f }, /* Cyrillic_YA Я CYRILLIC CAPITAL LETTER YA */ - { 0x06f2, 0x0420 }, /* Cyrillic_ER Р CYRILLIC CAPITAL LETTER ER */ - { 0x06f3, 0x0421 }, /* Cyrillic_ES С CYRILLIC CAPITAL LETTER ES */ - { 0x06f4, 0x0422 }, /* Cyrillic_TE Т CYRILLIC CAPITAL LETTER TE */ - { 0x06f5, 0x0423 }, /* Cyrillic_U У CYRILLIC CAPITAL LETTER U */ - { 0x06f6, 0x0416 }, /* Cyrillic_ZHE Ж CYRILLIC CAPITAL LETTER ZHE */ - { 0x06f7, 0x0412 }, /* Cyrillic_VE В CYRILLIC CAPITAL LETTER VE */ - { 0x06f8, 0x042c }, /* Cyrillic_SOFTSIGN Ь CYRILLIC CAPITAL LETTER SOFT SIGN */ - { 0x06f9, 0x042b }, /* Cyrillic_YERU Ы CYRILLIC CAPITAL LETTER YERU */ - { 0x06fa, 0x0417 }, /* Cyrillic_ZE З CYRILLIC CAPITAL LETTER ZE */ - { 0x06fb, 0x0428 }, /* Cyrillic_SHA Ш CYRILLIC CAPITAL LETTER SHA */ - { 0x06fc, 0x042d }, /* Cyrillic_E Э CYRILLIC CAPITAL LETTER E */ - { 0x06fd, 0x0429 }, /* Cyrillic_SHCHA Щ CYRILLIC CAPITAL LETTER SHCHA */ - { 0x06fe, 0x0427 }, /* Cyrillic_CHE Ч CYRILLIC CAPITAL LETTER CHE */ - { 0x06ff, 0x042a }, /* Cyrillic_HARDSIGN Ъ CYRILLIC CAPITAL LETTER HARD SIGN */ - { 0x07a1, 0x0386 }, /* Greek_ALPHAaccent Ά GREEK CAPITAL LETTER ALPHA WITH TONOS */ - { 0x07a2, 0x0388 }, /* Greek_EPSILONaccent Έ GREEK CAPITAL LETTER EPSILON WITH TONOS */ - { 0x07a3, 0x0389 }, /* Greek_ETAaccent Ή GREEK CAPITAL LETTER ETA WITH TONOS */ - { 0x07a4, 0x038a }, /* Greek_IOTAaccent Ί GREEK CAPITAL LETTER IOTA WITH TONOS */ - { 0x07a5, 0x03aa }, /* Greek_IOTAdiaeresis Ϊ GREEK CAPITAL LETTER IOTA WITH DIALYTIKA */ - { 0x07a7, 0x038c }, /* Greek_OMICRONaccent Ό GREEK CAPITAL LETTER OMICRON WITH TONOS */ - { 0x07a8, 0x038e }, /* Greek_UPSILONaccent Ύ GREEK CAPITAL LETTER UPSILON WITH TONOS */ - { 0x07a9, 0x03ab }, /* Greek_UPSILONdieresis Ϋ GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA */ - { 0x07ab, 0x038f }, /* Greek_OMEGAaccent Ώ GREEK CAPITAL LETTER OMEGA WITH TONOS */ - { 0x07ae, 0x0385 }, /* Greek_accentdieresis ΅ GREEK DIALYTIKA TONOS */ - { 0x07af, 0x2015 }, /* Greek_horizbar ― HORIZONTAL BAR */ - { 0x07b1, 0x03ac }, /* Greek_alphaaccent ά GREEK SMALL LETTER ALPHA WITH TONOS */ - { 0x07b2, 0x03ad }, /* Greek_epsilonaccent έ GREEK SMALL LETTER EPSILON WITH TONOS */ - { 0x07b3, 0x03ae }, /* Greek_etaaccent ή GREEK SMALL LETTER ETA WITH TONOS */ - { 0x07b4, 0x03af }, /* Greek_iotaaccent ί GREEK SMALL LETTER IOTA WITH TONOS */ - { 0x07b5, 0x03ca }, /* Greek_iotadieresis ϊ GREEK SMALL LETTER IOTA WITH DIALYTIKA */ - { 0x07b6, 0x0390 }, /* Greek_iotaaccentdieresis ΐ GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS */ - { 0x07b7, 0x03cc }, /* Greek_omicronaccent ό GREEK SMALL LETTER OMICRON WITH TONOS */ - { 0x07b8, 0x03cd }, /* Greek_upsilonaccent ύ GREEK SMALL LETTER UPSILON WITH TONOS */ - { 0x07b9, 0x03cb }, /* Greek_upsilondieresis ϋ GREEK SMALL LETTER UPSILON WITH DIALYTIKA */ - { 0x07ba, 0x03b0 }, /* Greek_upsilonaccentdieresis ΰ GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS */ - { 0x07bb, 0x03ce }, /* Greek_omegaaccent ώ GREEK SMALL LETTER OMEGA WITH TONOS */ - { 0x07c1, 0x0391 }, /* Greek_ALPHA Α GREEK CAPITAL LETTER ALPHA */ - { 0x07c2, 0x0392 }, /* Greek_BETA Β GREEK CAPITAL LETTER BETA */ - { 0x07c3, 0x0393 }, /* Greek_GAMMA Γ GREEK CAPITAL LETTER GAMMA */ - { 0x07c4, 0x0394 }, /* Greek_DELTA Δ GREEK CAPITAL LETTER DELTA */ - { 0x07c5, 0x0395 }, /* Greek_EPSILON Ε GREEK CAPITAL LETTER EPSILON */ - { 0x07c6, 0x0396 }, /* Greek_ZETA Ζ GREEK CAPITAL LETTER ZETA */ - { 0x07c7, 0x0397 }, /* Greek_ETA Η GREEK CAPITAL LETTER ETA */ - { 0x07c8, 0x0398 }, /* Greek_THETA Θ GREEK CAPITAL LETTER THETA */ - { 0x07c9, 0x0399 }, /* Greek_IOTA Ι GREEK CAPITAL LETTER IOTA */ - { 0x07ca, 0x039a }, /* Greek_KAPPA Κ GREEK CAPITAL LETTER KAPPA */ - { 0x07cb, 0x039b }, /* Greek_LAMBDA Λ GREEK CAPITAL LETTER LAMDA */ - { 0x07cc, 0x039c }, /* Greek_MU Μ GREEK CAPITAL LETTER MU */ - { 0x07cd, 0x039d }, /* Greek_NU Ν GREEK CAPITAL LETTER NU */ - { 0x07ce, 0x039e }, /* Greek_XI Ξ GREEK CAPITAL LETTER XI */ - { 0x07cf, 0x039f }, /* Greek_OMICRON Ο GREEK CAPITAL LETTER OMICRON */ - { 0x07d0, 0x03a0 }, /* Greek_PI Π GREEK CAPITAL LETTER PI */ - { 0x07d1, 0x03a1 }, /* Greek_RHO Ρ GREEK CAPITAL LETTER RHO */ - { 0x07d2, 0x03a3 }, /* Greek_SIGMA Σ GREEK CAPITAL LETTER SIGMA */ - { 0x07d4, 0x03a4 }, /* Greek_TAU Τ GREEK CAPITAL LETTER TAU */ - { 0x07d5, 0x03a5 }, /* Greek_UPSILON Υ GREEK CAPITAL LETTER UPSILON */ - { 0x07d6, 0x03a6 }, /* Greek_PHI Φ GREEK CAPITAL LETTER PHI */ - { 0x07d7, 0x03a7 }, /* Greek_CHI Χ GREEK CAPITAL LETTER CHI */ - { 0x07d8, 0x03a8 }, /* Greek_PSI Ψ GREEK CAPITAL LETTER PSI */ - { 0x07d9, 0x03a9 }, /* Greek_OMEGA Ω GREEK CAPITAL LETTER OMEGA */ - { 0x07e1, 0x03b1 }, /* Greek_alpha α GREEK SMALL LETTER ALPHA */ - { 0x07e2, 0x03b2 }, /* Greek_beta β GREEK SMALL LETTER BETA */ - { 0x07e3, 0x03b3 }, /* Greek_gamma γ GREEK SMALL LETTER GAMMA */ - { 0x07e4, 0x03b4 }, /* Greek_delta δ GREEK SMALL LETTER DELTA */ - { 0x07e5, 0x03b5 }, /* Greek_epsilon ε GREEK SMALL LETTER EPSILON */ - { 0x07e6, 0x03b6 }, /* Greek_zeta ζ GREEK SMALL LETTER ZETA */ - { 0x07e7, 0x03b7 }, /* Greek_eta η GREEK SMALL LETTER ETA */ - { 0x07e8, 0x03b8 }, /* Greek_theta θ GREEK SMALL LETTER THETA */ - { 0x07e9, 0x03b9 }, /* Greek_iota ι GREEK SMALL LETTER IOTA */ - { 0x07ea, 0x03ba }, /* Greek_kappa κ GREEK SMALL LETTER KAPPA */ - { 0x07eb, 0x03bb }, /* Greek_lambda λ GREEK SMALL LETTER LAMDA */ - { 0x07ec, 0x03bc }, /* Greek_mu μ GREEK SMALL LETTER MU */ - { 0x07ed, 0x03bd }, /* Greek_nu ν GREEK SMALL LETTER NU */ - { 0x07ee, 0x03be }, /* Greek_xi ξ GREEK SMALL LETTER XI */ - { 0x07ef, 0x03bf }, /* Greek_omicron ο GREEK SMALL LETTER OMICRON */ - { 0x07f0, 0x03c0 }, /* Greek_pi π GREEK SMALL LETTER PI */ - { 0x07f1, 0x03c1 }, /* Greek_rho ρ GREEK SMALL LETTER RHO */ - { 0x07f2, 0x03c3 }, /* Greek_sigma σ GREEK SMALL LETTER SIGMA */ - { 0x07f3, 0x03c2 }, /* Greek_finalsmallsigma ς GREEK SMALL LETTER FINAL SIGMA */ - { 0x07f4, 0x03c4 }, /* Greek_tau τ GREEK SMALL LETTER TAU */ - { 0x07f5, 0x03c5 }, /* Greek_upsilon υ GREEK SMALL LETTER UPSILON */ - { 0x07f6, 0x03c6 }, /* Greek_phi φ GREEK SMALL LETTER PHI */ - { 0x07f7, 0x03c7 }, /* Greek_chi χ GREEK SMALL LETTER CHI */ - { 0x07f8, 0x03c8 }, /* Greek_psi ψ GREEK SMALL LETTER PSI */ - { 0x07f9, 0x03c9 }, /* Greek_omega ω GREEK SMALL LETTER OMEGA */ - { 0x08a1, 0x23b7 }, /* leftradical ⎷ ??? */ - { 0x08a2, 0x250c }, /* topleftradical ┌ BOX DRAWINGS LIGHT DOWN AND RIGHT */ - { 0x08a3, 0x2500 }, /* horizconnector ─ BOX DRAWINGS LIGHT HORIZONTAL */ - { 0x08a4, 0x2320 }, /* topintegral ⌠ TOP HALF INTEGRAL */ - { 0x08a5, 0x2321 }, /* botintegral ⌡ BOTTOM HALF INTEGRAL */ - { 0x08a6, 0x2502 }, /* vertconnector │ BOX DRAWINGS LIGHT VERTICAL */ - { 0x08a7, 0x23a1 }, /* topleftsqbracket ⎡ ??? */ - { 0x08a8, 0x23a3 }, /* botleftsqbracket ⎣ ??? */ - { 0x08a9, 0x23a4 }, /* toprightsqbracket ⎤ ??? */ - { 0x08aa, 0x23a6 }, /* botrightsqbracket ⎦ ??? */ - { 0x08ab, 0x239b }, /* topleftparens ⎛ ??? */ - { 0x08ac, 0x239d }, /* botleftparens ⎝ ??? */ - { 0x08ad, 0x239e }, /* toprightparens ⎞ ??? */ - { 0x08ae, 0x23a0 }, /* botrightparens ⎠ ??? */ - { 0x08af, 0x23a8 }, /* leftmiddlecurlybrace ⎨ ??? */ - { 0x08b0, 0x23ac }, /* rightmiddlecurlybrace ⎬ ??? */ -/* 0x08b1 topleftsummation ? ??? */ -/* 0x08b2 botleftsummation ? ??? */ -/* 0x08b3 topvertsummationconnector ? ??? */ -/* 0x08b4 botvertsummationconnector ? ??? */ -/* 0x08b5 toprightsummation ? ??? */ -/* 0x08b6 botrightsummation ? ??? */ -/* 0x08b7 rightmiddlesummation ? ??? */ - { 0x08bc, 0x2264 }, /* lessthanequal ≤ LESS-THAN OR EQUAL TO */ - { 0x08bd, 0x2260 }, /* notequal ≠ NOT EQUAL TO */ - { 0x08be, 0x2265 }, /* greaterthanequal ≥ GREATER-THAN OR EQUAL TO */ - { 0x08bf, 0x222b }, /* integral ∫ INTEGRAL */ - { 0x08c0, 0x2234 }, /* therefore ∴ THEREFORE */ - { 0x08c1, 0x221d }, /* variation ∝ PROPORTIONAL TO */ - { 0x08c2, 0x221e }, /* infinity ∞ INFINITY */ - { 0x08c5, 0x2207 }, /* nabla ∇ NABLA */ - { 0x08c8, 0x223c }, /* approximate ∼ TILDE OPERATOR */ - { 0x08c9, 0x2243 }, /* similarequal ≃ ASYMPTOTICALLY EQUAL TO */ - { 0x08cd, 0x21d4 }, /* ifonlyif ⇔ LEFT RIGHT DOUBLE ARROW */ - { 0x08ce, 0x21d2 }, /* implies ⇒ RIGHTWARDS DOUBLE ARROW */ - { 0x08cf, 0x2261 }, /* identical ≡ IDENTICAL TO */ - { 0x08d6, 0x221a }, /* radical √ SQUARE ROOT */ - { 0x08da, 0x2282 }, /* includedin ⊂ SUBSET OF */ - { 0x08db, 0x2283 }, /* includes ⊃ SUPERSET OF */ - { 0x08dc, 0x2229 }, /* intersection ∩ INTERSECTION */ - { 0x08dd, 0x222a }, /* union ∪ UNION */ - { 0x08de, 0x2227 }, /* logicaland ∧ LOGICAL AND */ - { 0x08df, 0x2228 }, /* logicalor ∨ LOGICAL OR */ - { 0x08ef, 0x2202 }, /* partialderivative ∂ PARTIAL DIFFERENTIAL */ - { 0x08f6, 0x0192 }, /* function ƒ LATIN SMALL LETTER F WITH HOOK */ - { 0x08fb, 0x2190 }, /* leftarrow ← LEFTWARDS ARROW */ - { 0x08fc, 0x2191 }, /* uparrow ↑ UPWARDS ARROW */ - { 0x08fd, 0x2192 }, /* rightarrow → RIGHTWARDS ARROW */ - { 0x08fe, 0x2193 }, /* downarrow ↓ DOWNWARDS ARROW */ -/* 0x09df blank ? ??? */ - { 0x09e0, 0x25c6 }, /* soliddiamond ◆ BLACK DIAMOND */ - { 0x09e1, 0x2592 }, /* checkerboard ▒ MEDIUM SHADE */ - { 0x09e2, 0x2409 }, /* ht ␉ SYMBOL FOR HORIZONTAL TABULATION */ - { 0x09e3, 0x240c }, /* ff ␌ SYMBOL FOR FORM FEED */ - { 0x09e4, 0x240d }, /* cr ␍ SYMBOL FOR CARRIAGE RETURN */ - { 0x09e5, 0x240a }, /* lf ␊ SYMBOL FOR LINE FEED */ - { 0x09e8, 0x2424 }, /* nl ␤ SYMBOL FOR NEWLINE */ - { 0x09e9, 0x240b }, /* vt ␋ SYMBOL FOR VERTICAL TABULATION */ - { 0x09ea, 0x2518 }, /* lowrightcorner ┘ BOX DRAWINGS LIGHT UP AND LEFT */ - { 0x09eb, 0x2510 }, /* uprightcorner ┐ BOX DRAWINGS LIGHT DOWN AND LEFT */ - { 0x09ec, 0x250c }, /* upleftcorner ┌ BOX DRAWINGS LIGHT DOWN AND RIGHT */ - { 0x09ed, 0x2514 }, /* lowleftcorner └ BOX DRAWINGS LIGHT UP AND RIGHT */ - { 0x09ee, 0x253c }, /* crossinglines ┼ BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL */ - { 0x09ef, 0x23ba }, /* horizlinescan1 ⎺ HORIZONTAL SCAN LINE-1 (Unicode 3.2 draft) */ - { 0x09f0, 0x23bb }, /* horizlinescan3 ⎻ HORIZONTAL SCAN LINE-3 (Unicode 3.2 draft) */ - { 0x09f1, 0x2500 }, /* horizlinescan5 ─ BOX DRAWINGS LIGHT HORIZONTAL */ - { 0x09f2, 0x23bc }, /* horizlinescan7 ⎼ HORIZONTAL SCAN LINE-7 (Unicode 3.2 draft) */ - { 0x09f3, 0x23bd }, /* horizlinescan9 ⎽ HORIZONTAL SCAN LINE-9 (Unicode 3.2 draft) */ - { 0x09f4, 0x251c }, /* leftt ├ BOX DRAWINGS LIGHT VERTICAL AND RIGHT */ - { 0x09f5, 0x2524 }, /* rightt ┤ BOX DRAWINGS LIGHT VERTICAL AND LEFT */ - { 0x09f6, 0x2534 }, /* bott ┴ BOX DRAWINGS LIGHT UP AND HORIZONTAL */ - { 0x09f7, 0x252c }, /* topt ┬ BOX DRAWINGS LIGHT DOWN AND HORIZONTAL */ - { 0x09f8, 0x2502 }, /* vertbar │ BOX DRAWINGS LIGHT VERTICAL */ - { 0x0aa1, 0x2003 }, /* emspace   EM SPACE */ - { 0x0aa2, 0x2002 }, /* enspace   EN SPACE */ - { 0x0aa3, 0x2004 }, /* em3space   THREE-PER-EM SPACE */ - { 0x0aa4, 0x2005 }, /* em4space   FOUR-PER-EM SPACE */ - { 0x0aa5, 0x2007 }, /* digitspace   FIGURE SPACE */ - { 0x0aa6, 0x2008 }, /* punctspace   PUNCTUATION SPACE */ - { 0x0aa7, 0x2009 }, /* thinspace   THIN SPACE */ - { 0x0aa8, 0x200a }, /* hairspace   HAIR SPACE */ - { 0x0aa9, 0x2014 }, /* emdash — EM DASH */ - { 0x0aaa, 0x2013 }, /* endash – EN DASH */ -/* 0x0aac signifblank ? ??? */ - { 0x0aae, 0x2026 }, /* ellipsis … HORIZONTAL ELLIPSIS */ - { 0x0aaf, 0x2025 }, /* doubbaselinedot ‥ TWO DOT LEADER */ - { 0x0ab0, 0x2153 }, /* onethird ⅓ VULGAR FRACTION ONE THIRD */ - { 0x0ab1, 0x2154 }, /* twothirds ⅔ VULGAR FRACTION TWO THIRDS */ - { 0x0ab2, 0x2155 }, /* onefifth ⅕ VULGAR FRACTION ONE FIFTH */ - { 0x0ab3, 0x2156 }, /* twofifths ⅖ VULGAR FRACTION TWO FIFTHS */ - { 0x0ab4, 0x2157 }, /* threefifths ⅗ VULGAR FRACTION THREE FIFTHS */ - { 0x0ab5, 0x2158 }, /* fourfifths ⅘ VULGAR FRACTION FOUR FIFTHS */ - { 0x0ab6, 0x2159 }, /* onesixth ⅙ VULGAR FRACTION ONE SIXTH */ - { 0x0ab7, 0x215a }, /* fivesixths ⅚ VULGAR FRACTION FIVE SIXTHS */ - { 0x0ab8, 0x2105 }, /* careof ℅ CARE OF */ - { 0x0abb, 0x2012 }, /* figdash ‒ FIGURE DASH */ - { 0x0abc, 0x2329 }, /* leftanglebracket 〈 LEFT-POINTING ANGLE BRACKET */ -/* 0x0abd decimalpoint ? ??? */ - { 0x0abe, 0x232a }, /* rightanglebracket 〉 RIGHT-POINTING ANGLE BRACKET */ -/* 0x0abf marker ? ??? */ - { 0x0ac3, 0x215b }, /* oneeighth ⅛ VULGAR FRACTION ONE EIGHTH */ - { 0x0ac4, 0x215c }, /* threeeighths ⅜ VULGAR FRACTION THREE EIGHTHS */ - { 0x0ac5, 0x215d }, /* fiveeighths ⅝ VULGAR FRACTION FIVE EIGHTHS */ - { 0x0ac6, 0x215e }, /* seveneighths ⅞ VULGAR FRACTION SEVEN EIGHTHS */ - { 0x0ac9, 0x2122 }, /* trademark ™ TRADE MARK SIGN */ - { 0x0aca, 0x2613 }, /* signaturemark ☓ SALTIRE */ -/* 0x0acb trademarkincircle ? ??? */ - { 0x0acc, 0x25c1 }, /* leftopentriangle ◁ WHITE LEFT-POINTING TRIANGLE */ - { 0x0acd, 0x25b7 }, /* rightopentriangle ▷ WHITE RIGHT-POINTING TRIANGLE */ - { 0x0ace, 0x25cb }, /* emopencircle ○ WHITE CIRCLE */ - { 0x0acf, 0x25af }, /* emopenrectangle ▯ WHITE VERTICAL RECTANGLE */ - { 0x0ad0, 0x2018 }, /* leftsinglequotemark ‘ LEFT SINGLE QUOTATION MARK */ - { 0x0ad1, 0x2019 }, /* rightsinglequotemark ’ RIGHT SINGLE QUOTATION MARK */ - { 0x0ad2, 0x201c }, /* leftdoublequotemark “ LEFT DOUBLE QUOTATION MARK */ - { 0x0ad3, 0x201d }, /* rightdoublequotemark ” RIGHT DOUBLE QUOTATION MARK */ - { 0x0ad4, 0x211e }, /* prescription ℞ PRESCRIPTION TAKE */ - { 0x0ad6, 0x2032 }, /* minutes ′ PRIME */ - { 0x0ad7, 0x2033 }, /* seconds ″ DOUBLE PRIME */ - { 0x0ad9, 0x271d }, /* latincross ✝ LATIN CROSS */ -/* 0x0ada hexagram ? ??? */ - { 0x0adb, 0x25ac }, /* filledrectbullet ▬ BLACK RECTANGLE */ - { 0x0adc, 0x25c0 }, /* filledlefttribullet ◀ BLACK LEFT-POINTING TRIANGLE */ - { 0x0add, 0x25b6 }, /* filledrighttribullet ▶ BLACK RIGHT-POINTING TRIANGLE */ - { 0x0ade, 0x25cf }, /* emfilledcircle ● BLACK CIRCLE */ - { 0x0adf, 0x25ae }, /* emfilledrect ▮ BLACK VERTICAL RECTANGLE */ - { 0x0ae0, 0x25e6 }, /* enopencircbullet ◦ WHITE BULLET */ - { 0x0ae1, 0x25ab }, /* enopensquarebullet ▫ WHITE SMALL SQUARE */ - { 0x0ae2, 0x25ad }, /* openrectbullet ▭ WHITE RECTANGLE */ - { 0x0ae3, 0x25b3 }, /* opentribulletup △ WHITE UP-POINTING TRIANGLE */ - { 0x0ae4, 0x25bd }, /* opentribulletdown ▽ WHITE DOWN-POINTING TRIANGLE */ - { 0x0ae5, 0x2606 }, /* openstar ☆ WHITE STAR */ - { 0x0ae6, 0x2022 }, /* enfilledcircbullet • BULLET */ - { 0x0ae7, 0x25aa }, /* enfilledsqbullet ▪ BLACK SMALL SQUARE */ - { 0x0ae8, 0x25b2 }, /* filledtribulletup ▲ BLACK UP-POINTING TRIANGLE */ - { 0x0ae9, 0x25bc }, /* filledtribulletdown ▼ BLACK DOWN-POINTING TRIANGLE */ - { 0x0aea, 0x261c }, /* leftpointer ☜ WHITE LEFT POINTING INDEX */ - { 0x0aeb, 0x261e }, /* rightpointer ☞ WHITE RIGHT POINTING INDEX */ - { 0x0aec, 0x2663 }, /* club ♣ BLACK CLUB SUIT */ - { 0x0aed, 0x2666 }, /* diamond ♦ BLACK DIAMOND SUIT */ - { 0x0aee, 0x2665 }, /* heart ♥ BLACK HEART SUIT */ - { 0x0af0, 0x2720 }, /* maltesecross ✠ MALTESE CROSS */ - { 0x0af1, 0x2020 }, /* dagger † DAGGER */ - { 0x0af2, 0x2021 }, /* doubledagger ‡ DOUBLE DAGGER */ - { 0x0af3, 0x2713 }, /* checkmark ✓ CHECK MARK */ - { 0x0af4, 0x2717 }, /* ballotcross ✗ BALLOT X */ - { 0x0af5, 0x266f }, /* musicalsharp ♯ MUSIC SHARP SIGN */ - { 0x0af6, 0x266d }, /* musicalflat ♭ MUSIC FLAT SIGN */ - { 0x0af7, 0x2642 }, /* malesymbol ♂ MALE SIGN */ - { 0x0af8, 0x2640 }, /* femalesymbol ♀ FEMALE SIGN */ - { 0x0af9, 0x260e }, /* telephone ☎ BLACK TELEPHONE */ - { 0x0afa, 0x2315 }, /* telephonerecorder ⌕ TELEPHONE RECORDER */ - { 0x0afb, 0x2117 }, /* phonographcopyright ℗ SOUND RECORDING COPYRIGHT */ - { 0x0afc, 0x2038 }, /* caret ‸ CARET */ - { 0x0afd, 0x201a }, /* singlelowquotemark ‚ SINGLE LOW-9 QUOTATION MARK */ - { 0x0afe, 0x201e }, /* doublelowquotemark „ DOUBLE LOW-9 QUOTATION MARK */ -/* 0x0aff cursor ? ??? */ - { 0x0ba3, 0x003c }, /* leftcaret < LESS-THAN SIGN */ - { 0x0ba6, 0x003e }, /* rightcaret > GREATER-THAN SIGN */ - { 0x0ba8, 0x2228 }, /* downcaret ∨ LOGICAL OR */ - { 0x0ba9, 0x2227 }, /* upcaret ∧ LOGICAL AND */ - { 0x0bc0, 0x00af }, /* overbar ¯ MACRON */ - { 0x0bc2, 0x22a5 }, /* downtack ⊥ UP TACK */ - { 0x0bc3, 0x2229 }, /* upshoe ∩ INTERSECTION */ - { 0x0bc4, 0x230a }, /* downstile ⌊ LEFT FLOOR */ - { 0x0bc6, 0x005f }, /* underbar _ LOW LINE */ - { 0x0bca, 0x2218 }, /* jot ∘ RING OPERATOR */ - { 0x0bcc, 0x2395 }, /* quad ⎕ APL FUNCTIONAL SYMBOL QUAD */ - { 0x0bce, 0x22a4 }, /* uptack ⊤ DOWN TACK */ - { 0x0bcf, 0x25cb }, /* circle ○ WHITE CIRCLE */ - { 0x0bd3, 0x2308 }, /* upstile ⌈ LEFT CEILING */ - { 0x0bd6, 0x222a }, /* downshoe ∪ UNION */ - { 0x0bd8, 0x2283 }, /* rightshoe ⊃ SUPERSET OF */ - { 0x0bda, 0x2282 }, /* leftshoe ⊂ SUBSET OF */ - { 0x0bdc, 0x22a2 }, /* lefttack ⊢ RIGHT TACK */ - { 0x0bfc, 0x22a3 }, /* righttack ⊣ LEFT TACK */ - { 0x0cdf, 0x2017 }, /* hebrew_doublelowline ‗ DOUBLE LOW LINE */ - { 0x0ce0, 0x05d0 }, /* hebrew_aleph א HEBREW LETTER ALEF */ - { 0x0ce1, 0x05d1 }, /* hebrew_bet ב HEBREW LETTER BET */ - { 0x0ce2, 0x05d2 }, /* hebrew_gimel ג HEBREW LETTER GIMEL */ - { 0x0ce3, 0x05d3 }, /* hebrew_dalet ד HEBREW LETTER DALET */ - { 0x0ce4, 0x05d4 }, /* hebrew_he ה HEBREW LETTER HE */ - { 0x0ce5, 0x05d5 }, /* hebrew_waw ו HEBREW LETTER VAV */ - { 0x0ce6, 0x05d6 }, /* hebrew_zain ז HEBREW LETTER ZAYIN */ - { 0x0ce7, 0x05d7 }, /* hebrew_chet ח HEBREW LETTER HET */ - { 0x0ce8, 0x05d8 }, /* hebrew_tet ט HEBREW LETTER TET */ - { 0x0ce9, 0x05d9 }, /* hebrew_yod י HEBREW LETTER YOD */ - { 0x0cea, 0x05da }, /* hebrew_finalkaph ך HEBREW LETTER FINAL KAF */ - { 0x0ceb, 0x05db }, /* hebrew_kaph כ HEBREW LETTER KAF */ - { 0x0cec, 0x05dc }, /* hebrew_lamed ל HEBREW LETTER LAMED */ - { 0x0ced, 0x05dd }, /* hebrew_finalmem ם HEBREW LETTER FINAL MEM */ - { 0x0cee, 0x05de }, /* hebrew_mem מ HEBREW LETTER MEM */ - { 0x0cef, 0x05df }, /* hebrew_finalnun ן HEBREW LETTER FINAL NUN */ - { 0x0cf0, 0x05e0 }, /* hebrew_nun נ HEBREW LETTER NUN */ - { 0x0cf1, 0x05e1 }, /* hebrew_samech ס HEBREW LETTER SAMEKH */ - { 0x0cf2, 0x05e2 }, /* hebrew_ayin ע HEBREW LETTER AYIN */ - { 0x0cf3, 0x05e3 }, /* hebrew_finalpe ף HEBREW LETTER FINAL PE */ - { 0x0cf4, 0x05e4 }, /* hebrew_pe פ HEBREW LETTER PE */ - { 0x0cf5, 0x05e5 }, /* hebrew_finalzade ץ HEBREW LETTER FINAL TSADI */ - { 0x0cf6, 0x05e6 }, /* hebrew_zade צ HEBREW LETTER TSADI */ - { 0x0cf7, 0x05e7 }, /* hebrew_qoph ק HEBREW LETTER QOF */ - { 0x0cf8, 0x05e8 }, /* hebrew_resh ר HEBREW LETTER RESH */ - { 0x0cf9, 0x05e9 }, /* hebrew_shin ש HEBREW LETTER SHIN */ - { 0x0cfa, 0x05ea }, /* hebrew_taw ת HEBREW LETTER TAV */ - { 0x0da1, 0x0e01 }, /* Thai_kokai ก THAI CHARACTER KO KAI */ - { 0x0da2, 0x0e02 }, /* Thai_khokhai ข THAI CHARACTER KHO KHAI */ - { 0x0da3, 0x0e03 }, /* Thai_khokhuat ฃ THAI CHARACTER KHO KHUAT */ - { 0x0da4, 0x0e04 }, /* Thai_khokhwai ค THAI CHARACTER KHO KHWAI */ - { 0x0da5, 0x0e05 }, /* Thai_khokhon ฅ THAI CHARACTER KHO KHON */ - { 0x0da6, 0x0e06 }, /* Thai_khorakhang ฆ THAI CHARACTER KHO RAKHANG */ - { 0x0da7, 0x0e07 }, /* Thai_ngongu ง THAI CHARACTER NGO NGU */ - { 0x0da8, 0x0e08 }, /* Thai_chochan จ THAI CHARACTER CHO CHAN */ - { 0x0da9, 0x0e09 }, /* Thai_choching ฉ THAI CHARACTER CHO CHING */ - { 0x0daa, 0x0e0a }, /* Thai_chochang ช THAI CHARACTER CHO CHANG */ - { 0x0dab, 0x0e0b }, /* Thai_soso ซ THAI CHARACTER SO SO */ - { 0x0dac, 0x0e0c }, /* Thai_chochoe ฌ THAI CHARACTER CHO CHOE */ - { 0x0dad, 0x0e0d }, /* Thai_yoying ญ THAI CHARACTER YO YING */ - { 0x0dae, 0x0e0e }, /* Thai_dochada ฎ THAI CHARACTER DO CHADA */ - { 0x0daf, 0x0e0f }, /* Thai_topatak ฏ THAI CHARACTER TO PATAK */ - { 0x0db0, 0x0e10 }, /* Thai_thothan ฐ THAI CHARACTER THO THAN */ - { 0x0db1, 0x0e11 }, /* Thai_thonangmontho ฑ THAI CHARACTER THO NANGMONTHO */ - { 0x0db2, 0x0e12 }, /* Thai_thophuthao ฒ THAI CHARACTER THO PHUTHAO */ - { 0x0db3, 0x0e13 }, /* Thai_nonen ณ THAI CHARACTER NO NEN */ - { 0x0db4, 0x0e14 }, /* Thai_dodek ด THAI CHARACTER DO DEK */ - { 0x0db5, 0x0e15 }, /* Thai_totao ต THAI CHARACTER TO TAO */ - { 0x0db6, 0x0e16 }, /* Thai_thothung ถ THAI CHARACTER THO THUNG */ - { 0x0db7, 0x0e17 }, /* Thai_thothahan ท THAI CHARACTER THO THAHAN */ - { 0x0db8, 0x0e18 }, /* Thai_thothong ธ THAI CHARACTER THO THONG */ - { 0x0db9, 0x0e19 }, /* Thai_nonu น THAI CHARACTER NO NU */ - { 0x0dba, 0x0e1a }, /* Thai_bobaimai บ THAI CHARACTER BO BAIMAI */ - { 0x0dbb, 0x0e1b }, /* Thai_popla ป THAI CHARACTER PO PLA */ - { 0x0dbc, 0x0e1c }, /* Thai_phophung ผ THAI CHARACTER PHO PHUNG */ - { 0x0dbd, 0x0e1d }, /* Thai_fofa ฝ THAI CHARACTER FO FA */ - { 0x0dbe, 0x0e1e }, /* Thai_phophan พ THAI CHARACTER PHO PHAN */ - { 0x0dbf, 0x0e1f }, /* Thai_fofan ฟ THAI CHARACTER FO FAN */ - { 0x0dc0, 0x0e20 }, /* Thai_phosamphao ภ THAI CHARACTER PHO SAMPHAO */ - { 0x0dc1, 0x0e21 }, /* Thai_moma ม THAI CHARACTER MO MA */ - { 0x0dc2, 0x0e22 }, /* Thai_yoyak ย THAI CHARACTER YO YAK */ - { 0x0dc3, 0x0e23 }, /* Thai_rorua ร THAI CHARACTER RO RUA */ - { 0x0dc4, 0x0e24 }, /* Thai_ru ฤ THAI CHARACTER RU */ - { 0x0dc5, 0x0e25 }, /* Thai_loling ล THAI CHARACTER LO LING */ - { 0x0dc6, 0x0e26 }, /* Thai_lu ฦ THAI CHARACTER LU */ - { 0x0dc7, 0x0e27 }, /* Thai_wowaen ว THAI CHARACTER WO WAEN */ - { 0x0dc8, 0x0e28 }, /* Thai_sosala ศ THAI CHARACTER SO SALA */ - { 0x0dc9, 0x0e29 }, /* Thai_sorusi ษ THAI CHARACTER SO RUSI */ - { 0x0dca, 0x0e2a }, /* Thai_sosua ส THAI CHARACTER SO SUA */ - { 0x0dcb, 0x0e2b }, /* Thai_hohip ห THAI CHARACTER HO HIP */ - { 0x0dcc, 0x0e2c }, /* Thai_lochula ฬ THAI CHARACTER LO CHULA */ - { 0x0dcd, 0x0e2d }, /* Thai_oang อ THAI CHARACTER O ANG */ - { 0x0dce, 0x0e2e }, /* Thai_honokhuk ฮ THAI CHARACTER HO NOKHUK */ - { 0x0dcf, 0x0e2f }, /* Thai_paiyannoi ฯ THAI CHARACTER PAIYANNOI */ - { 0x0dd0, 0x0e30 }, /* Thai_saraa ะ THAI CHARACTER SARA A */ - { 0x0dd1, 0x0e31 }, /* Thai_maihanakat ั THAI CHARACTER MAI HAN-AKAT */ - { 0x0dd2, 0x0e32 }, /* Thai_saraaa า THAI CHARACTER SARA AA */ - { 0x0dd3, 0x0e33 }, /* Thai_saraam ำ THAI CHARACTER SARA AM */ - { 0x0dd4, 0x0e34 }, /* Thai_sarai ิ THAI CHARACTER SARA I */ - { 0x0dd5, 0x0e35 }, /* Thai_saraii ี THAI CHARACTER SARA II */ - { 0x0dd6, 0x0e36 }, /* Thai_saraue ึ THAI CHARACTER SARA UE */ - { 0x0dd7, 0x0e37 }, /* Thai_sarauee ื THAI CHARACTER SARA UEE */ - { 0x0dd8, 0x0e38 }, /* Thai_sarau ุ THAI CHARACTER SARA U */ - { 0x0dd9, 0x0e39 }, /* Thai_sarauu ู THAI CHARACTER SARA UU */ - { 0x0dda, 0x0e3a }, /* Thai_phinthu ฺ THAI CHARACTER PHINTHU */ -/* 0x0dde Thai_maihanakat_maitho ? ??? */ - { 0x0ddf, 0x0e3f }, /* Thai_baht ฿ THAI CURRENCY SYMBOL BAHT */ - { 0x0de0, 0x0e40 }, /* Thai_sarae เ THAI CHARACTER SARA E */ - { 0x0de1, 0x0e41 }, /* Thai_saraae แ THAI CHARACTER SARA AE */ - { 0x0de2, 0x0e42 }, /* Thai_sarao โ THAI CHARACTER SARA O */ - { 0x0de3, 0x0e43 }, /* Thai_saraaimaimuan ใ THAI CHARACTER SARA AI MAIMUAN */ - { 0x0de4, 0x0e44 }, /* Thai_saraaimaimalai ไ THAI CHARACTER SARA AI MAIMALAI */ - { 0x0de5, 0x0e45 }, /* Thai_lakkhangyao ๅ THAI CHARACTER LAKKHANGYAO */ - { 0x0de6, 0x0e46 }, /* Thai_maiyamok ๆ THAI CHARACTER MAIYAMOK */ - { 0x0de7, 0x0e47 }, /* Thai_maitaikhu ็ THAI CHARACTER MAITAIKHU */ - { 0x0de8, 0x0e48 }, /* Thai_maiek ่ THAI CHARACTER MAI EK */ - { 0x0de9, 0x0e49 }, /* Thai_maitho ้ THAI CHARACTER MAI THO */ - { 0x0dea, 0x0e4a }, /* Thai_maitri ๊ THAI CHARACTER MAI TRI */ - { 0x0deb, 0x0e4b }, /* Thai_maichattawa ๋ THAI CHARACTER MAI CHATTAWA */ - { 0x0dec, 0x0e4c }, /* Thai_thanthakhat ์ THAI CHARACTER THANTHAKHAT */ - { 0x0ded, 0x0e4d }, /* Thai_nikhahit ํ THAI CHARACTER NIKHAHIT */ - { 0x0df0, 0x0e50 }, /* Thai_leksun ๐ THAI DIGIT ZERO */ - { 0x0df1, 0x0e51 }, /* Thai_leknung ๑ THAI DIGIT ONE */ - { 0x0df2, 0x0e52 }, /* Thai_leksong ๒ THAI DIGIT TWO */ - { 0x0df3, 0x0e53 }, /* Thai_leksam ๓ THAI DIGIT THREE */ - { 0x0df4, 0x0e54 }, /* Thai_leksi ๔ THAI DIGIT FOUR */ - { 0x0df5, 0x0e55 }, /* Thai_lekha ๕ THAI DIGIT FIVE */ - { 0x0df6, 0x0e56 }, /* Thai_lekhok ๖ THAI DIGIT SIX */ - { 0x0df7, 0x0e57 }, /* Thai_lekchet ๗ THAI DIGIT SEVEN */ - { 0x0df8, 0x0e58 }, /* Thai_lekpaet ๘ THAI DIGIT EIGHT */ - { 0x0df9, 0x0e59 }, /* Thai_lekkao ๙ THAI DIGIT NINE */ - { 0x0ea1, 0x3131 }, /* Hangul_Kiyeog ㄱ HANGUL LETTER KIYEOK */ - { 0x0ea2, 0x3132 }, /* Hangul_SsangKiyeog ㄲ HANGUL LETTER SSANGKIYEOK */ - { 0x0ea3, 0x3133 }, /* Hangul_KiyeogSios ㄳ HANGUL LETTER KIYEOK-SIOS */ - { 0x0ea4, 0x3134 }, /* Hangul_Nieun ㄴ HANGUL LETTER NIEUN */ - { 0x0ea5, 0x3135 }, /* Hangul_NieunJieuj ㄵ HANGUL LETTER NIEUN-CIEUC */ - { 0x0ea6, 0x3136 }, /* Hangul_NieunHieuh ㄶ HANGUL LETTER NIEUN-HIEUH */ - { 0x0ea7, 0x3137 }, /* Hangul_Dikeud ㄷ HANGUL LETTER TIKEUT */ - { 0x0ea8, 0x3138 }, /* Hangul_SsangDikeud ㄸ HANGUL LETTER SSANGTIKEUT */ - { 0x0ea9, 0x3139 }, /* Hangul_Rieul ㄹ HANGUL LETTER RIEUL */ - { 0x0eaa, 0x313a }, /* Hangul_RieulKiyeog ㄺ HANGUL LETTER RIEUL-KIYEOK */ - { 0x0eab, 0x313b }, /* Hangul_RieulMieum ㄻ HANGUL LETTER RIEUL-MIEUM */ - { 0x0eac, 0x313c }, /* Hangul_RieulPieub ㄼ HANGUL LETTER RIEUL-PIEUP */ - { 0x0ead, 0x313d }, /* Hangul_RieulSios ㄽ HANGUL LETTER RIEUL-SIOS */ - { 0x0eae, 0x313e }, /* Hangul_RieulTieut ㄾ HANGUL LETTER RIEUL-THIEUTH */ - { 0x0eaf, 0x313f }, /* Hangul_RieulPhieuf ㄿ HANGUL LETTER RIEUL-PHIEUPH */ - { 0x0eb0, 0x3140 }, /* Hangul_RieulHieuh ㅀ HANGUL LETTER RIEUL-HIEUH */ - { 0x0eb1, 0x3141 }, /* Hangul_Mieum ㅁ HANGUL LETTER MIEUM */ - { 0x0eb2, 0x3142 }, /* Hangul_Pieub ㅂ HANGUL LETTER PIEUP */ - { 0x0eb3, 0x3143 }, /* Hangul_SsangPieub ㅃ HANGUL LETTER SSANGPIEUP */ - { 0x0eb4, 0x3144 }, /* Hangul_PieubSios ㅄ HANGUL LETTER PIEUP-SIOS */ - { 0x0eb5, 0x3145 }, /* Hangul_Sios ㅅ HANGUL LETTER SIOS */ - { 0x0eb6, 0x3146 }, /* Hangul_SsangSios ㅆ HANGUL LETTER SSANGSIOS */ - { 0x0eb7, 0x3147 }, /* Hangul_Ieung ㅇ HANGUL LETTER IEUNG */ - { 0x0eb8, 0x3148 }, /* Hangul_Jieuj ㅈ HANGUL LETTER CIEUC */ - { 0x0eb9, 0x3149 }, /* Hangul_SsangJieuj ㅉ HANGUL LETTER SSANGCIEUC */ - { 0x0eba, 0x314a }, /* Hangul_Cieuc ㅊ HANGUL LETTER CHIEUCH */ - { 0x0ebb, 0x314b }, /* Hangul_Khieuq ㅋ HANGUL LETTER KHIEUKH */ - { 0x0ebc, 0x314c }, /* Hangul_Tieut ㅌ HANGUL LETTER THIEUTH */ - { 0x0ebd, 0x314d }, /* Hangul_Phieuf ㅍ HANGUL LETTER PHIEUPH */ - { 0x0ebe, 0x314e }, /* Hangul_Hieuh ㅎ HANGUL LETTER HIEUH */ - { 0x0ebf, 0x314f }, /* Hangul_A ㅏ HANGUL LETTER A */ - { 0x0ec0, 0x3150 }, /* Hangul_AE ㅐ HANGUL LETTER AE */ - { 0x0ec1, 0x3151 }, /* Hangul_YA ㅑ HANGUL LETTER YA */ - { 0x0ec2, 0x3152 }, /* Hangul_YAE ㅒ HANGUL LETTER YAE */ - { 0x0ec3, 0x3153 }, /* Hangul_EO ㅓ HANGUL LETTER EO */ - { 0x0ec4, 0x3154 }, /* Hangul_E ㅔ HANGUL LETTER E */ - { 0x0ec5, 0x3155 }, /* Hangul_YEO ㅕ HANGUL LETTER YEO */ - { 0x0ec6, 0x3156 }, /* Hangul_YE ㅖ HANGUL LETTER YE */ - { 0x0ec7, 0x3157 }, /* Hangul_O ㅗ HANGUL LETTER O */ - { 0x0ec8, 0x3158 }, /* Hangul_WA ㅘ HANGUL LETTER WA */ - { 0x0ec9, 0x3159 }, /* Hangul_WAE ㅙ HANGUL LETTER WAE */ - { 0x0eca, 0x315a }, /* Hangul_OE ㅚ HANGUL LETTER OE */ - { 0x0ecb, 0x315b }, /* Hangul_YO ㅛ HANGUL LETTER YO */ - { 0x0ecc, 0x315c }, /* Hangul_U ㅜ HANGUL LETTER U */ - { 0x0ecd, 0x315d }, /* Hangul_WEO ㅝ HANGUL LETTER WEO */ - { 0x0ece, 0x315e }, /* Hangul_WE ㅞ HANGUL LETTER WE */ - { 0x0ecf, 0x315f }, /* Hangul_WI ㅟ HANGUL LETTER WI */ - { 0x0ed0, 0x3160 }, /* Hangul_YU ㅠ HANGUL LETTER YU */ - { 0x0ed1, 0x3161 }, /* Hangul_EU ㅡ HANGUL LETTER EU */ - { 0x0ed2, 0x3162 }, /* Hangul_YI ㅢ HANGUL LETTER YI */ - { 0x0ed3, 0x3163 }, /* Hangul_I ㅣ HANGUL LETTER I */ - { 0x0ed4, 0x11a8 }, /* Hangul_J_Kiyeog ᆨ HANGUL JONGSEONG KIYEOK */ - { 0x0ed5, 0x11a9 }, /* Hangul_J_SsangKiyeog ᆩ HANGUL JONGSEONG SSANGKIYEOK */ - { 0x0ed6, 0x11aa }, /* Hangul_J_KiyeogSios ᆪ HANGUL JONGSEONG KIYEOK-SIOS */ - { 0x0ed7, 0x11ab }, /* Hangul_J_Nieun ᆫ HANGUL JONGSEONG NIEUN */ - { 0x0ed8, 0x11ac }, /* Hangul_J_NieunJieuj ᆬ HANGUL JONGSEONG NIEUN-CIEUC */ - { 0x0ed9, 0x11ad }, /* Hangul_J_NieunHieuh ᆭ HANGUL JONGSEONG NIEUN-HIEUH */ - { 0x0eda, 0x11ae }, /* Hangul_J_Dikeud ᆮ HANGUL JONGSEONG TIKEUT */ - { 0x0edb, 0x11af }, /* Hangul_J_Rieul ᆯ HANGUL JONGSEONG RIEUL */ - { 0x0edc, 0x11b0 }, /* Hangul_J_RieulKiyeog ᆰ HANGUL JONGSEONG RIEUL-KIYEOK */ - { 0x0edd, 0x11b1 }, /* Hangul_J_RieulMieum ᆱ HANGUL JONGSEONG RIEUL-MIEUM */ - { 0x0ede, 0x11b2 }, /* Hangul_J_RieulPieub ᆲ HANGUL JONGSEONG RIEUL-PIEUP */ - { 0x0edf, 0x11b3 }, /* Hangul_J_RieulSios ᆳ HANGUL JONGSEONG RIEUL-SIOS */ - { 0x0ee0, 0x11b4 }, /* Hangul_J_RieulTieut ᆴ HANGUL JONGSEONG RIEUL-THIEUTH */ - { 0x0ee1, 0x11b5 }, /* Hangul_J_RieulPhieuf ᆵ HANGUL JONGSEONG RIEUL-PHIEUPH */ - { 0x0ee2, 0x11b6 }, /* Hangul_J_RieulHieuh ᆶ HANGUL JONGSEONG RIEUL-HIEUH */ - { 0x0ee3, 0x11b7 }, /* Hangul_J_Mieum ᆷ HANGUL JONGSEONG MIEUM */ - { 0x0ee4, 0x11b8 }, /* Hangul_J_Pieub ᆸ HANGUL JONGSEONG PIEUP */ - { 0x0ee5, 0x11b9 }, /* Hangul_J_PieubSios ᆹ HANGUL JONGSEONG PIEUP-SIOS */ - { 0x0ee6, 0x11ba }, /* Hangul_J_Sios ᆺ HANGUL JONGSEONG SIOS */ - { 0x0ee7, 0x11bb }, /* Hangul_J_SsangSios ᆻ HANGUL JONGSEONG SSANGSIOS */ - { 0x0ee8, 0x11bc }, /* Hangul_J_Ieung ᆼ HANGUL JONGSEONG IEUNG */ - { 0x0ee9, 0x11bd }, /* Hangul_J_Jieuj ᆽ HANGUL JONGSEONG CIEUC */ - { 0x0eea, 0x11be }, /* Hangul_J_Cieuc ᆾ HANGUL JONGSEONG CHIEUCH */ - { 0x0eeb, 0x11bf }, /* Hangul_J_Khieuq ᆿ HANGUL JONGSEONG KHIEUKH */ - { 0x0eec, 0x11c0 }, /* Hangul_J_Tieut ᇀ HANGUL JONGSEONG THIEUTH */ - { 0x0eed, 0x11c1 }, /* Hangul_J_Phieuf ᇁ HANGUL JONGSEONG PHIEUPH */ - { 0x0eee, 0x11c2 }, /* Hangul_J_Hieuh ᇂ HANGUL JONGSEONG HIEUH */ - { 0x0eef, 0x316d }, /* Hangul_RieulYeorinHieuh ㅭ HANGUL LETTER RIEUL-YEORINHIEUH */ - { 0x0ef0, 0x3171 }, /* Hangul_SunkyeongeumMieum ㅱ HANGUL LETTER KAPYEOUNMIEUM */ - { 0x0ef1, 0x3178 }, /* Hangul_SunkyeongeumPieub ㅸ HANGUL LETTER KAPYEOUNPIEUP */ - { 0x0ef2, 0x317f }, /* Hangul_PanSios ㅿ HANGUL LETTER PANSIOS */ - { 0x0ef3, 0x3181 }, /* Hangul_KkogjiDalrinIeung ㆁ HANGUL LETTER YESIEUNG */ - { 0x0ef4, 0x3184 }, /* Hangul_SunkyeongeumPhieuf ㆄ HANGUL LETTER KAPYEOUNPHIEUPH */ - { 0x0ef5, 0x3186 }, /* Hangul_YeorinHieuh ㆆ HANGUL LETTER YEORINHIEUH */ - { 0x0ef6, 0x318d }, /* Hangul_AraeA ㆍ HANGUL LETTER ARAEA */ - { 0x0ef7, 0x318e }, /* Hangul_AraeAE ㆎ HANGUL LETTER ARAEAE */ - { 0x0ef8, 0x11eb }, /* Hangul_J_PanSios ᇫ HANGUL JONGSEONG PANSIOS */ - { 0x0ef9, 0x11f0 }, /* Hangul_J_KkogjiDalrinIeung ᇰ HANGUL JONGSEONG YESIEUNG */ - { 0x0efa, 0x11f9 }, /* Hangul_J_YeorinHieuh ᇹ HANGUL JONGSEONG YEORINHIEUH */ - { 0x0eff, 0x20a9 }, /* Korean_Won ₩ WON SIGN */ - { 0x13a4, 0x20ac }, /* Euro € EURO SIGN */ - { 0x13bc, 0x0152 }, /* OE Œ LATIN CAPITAL LIGATURE OE */ - { 0x13bd, 0x0153 }, /* oe œ LATIN SMALL LIGATURE OE */ - { 0x13be, 0x0178 }, /* Ydiaeresis Ÿ LATIN CAPITAL LETTER Y WITH DIAERESIS */ - { 0x20ac, 0x20ac }, /* EuroSign € EURO SIGN */ -}; - -long keysym2ucs(unsigned short keysym) -{ - int min = 0; - int max = sizeof(keysymtab) / sizeof(struct codepair) - 1; - int mid; - - /* first check for Latin-1 characters (1:1 mapping) */ - if ((keysym >= 0x0020 && keysym <= 0x007e) || - (keysym >= 0x00a0 && keysym <= 0x00ff)) - return keysym; - - /* also check for directly encoded 24-bit UCS characters */ - if ((keysym & 0xff000000) == 0x01000000) - return keysym & 0x00ffffff; - - /* binary search in table */ - while (max >= min) { - mid = (min + max) / 2; - if (keysymtab[mid].keysym < keysym) - min = mid + 1; - else if (keysymtab[mid].keysym > keysym) - max = mid - 1; - else { - /* found it */ - return keysymtab[mid].ucs; - } - } - - /* no matching Unicode value found */ - return -1; -} diff --git a/wsi/x11/wsi.ml b/wsi/x11/wsi.ml deleted file mode 100644 index e1903fc..0000000 --- a/wsi/x11/wsi.ml +++ /dev/null @@ -1,1199 +0,0 @@ -open Utils - -let (~>) = Bytes.unsafe_of_string - -type cursor = - | CURSOR_INHERIT - | CURSOR_INFO - | CURSOR_CYCLE - | CURSOR_FLEUR - | CURSOR_TEXT - -type winstate = - | MaxVert - | MaxHorz - | Fullscreen - -type visiblestate = - | Unobscured - | PartiallyObscured - | FullyObscured - -type wid = int and screenno = int and vid = int - -external glxinit : string -> wid -> screenno -> vid = "ml_glxinit" -external glxcompleteinit : unit -> unit = "ml_glxcompleteinit" -external swapb : unit -> unit = "ml_swapb" -external setcursor : cursor -> unit = "ml_setcursor" - -class type t = - object - method display : unit - method map : bool -> unit - method expose : unit - method visible : visiblestate -> unit - method reshape : int -> int -> unit - method mouse : int -> bool -> int -> int -> int -> unit - method motion : int -> int -> unit - method pmotion : int -> int -> unit - method key : int -> int -> unit - method enter : int -> int -> unit - method leave : unit - method winstate : winstate list -> unit - method quit : 'a. 'a - method scroll : int -> int -> unit - method zoom : float -> int -> int -> unit - method opendoc : string -> unit - end - -module S = struct - type fs = - | NoFs - | Fs of (int * int * int * int) - - let mink = ref max_int - let maxk = ref min_int - let keymap = ref E.a - let fifo = ref (Queue.create ()) - let seq = ref 0 - let protoatom = ref ~-1 - let deleatom = ref ~-1 - let nwmsatom = ref ~-1 - let maxvatom = ref ~-1 - let maxhatom = ref ~-1 - let fulsatom = ref ~-1 - let idbase = ref ~-1 - let wid = ref ~-1 - let fid = ref ~-1 - let fullscreen = ref (fun _ -> ()) - let setwmname = ref (fun _ -> ()) - let actwin = ref (fun _ -> ()) - let sock = ref Unix.stdin - let x = ref ~-1 - let y = ref ~-1 - let w = ref ~-1 - let h = ref ~-1 - let fs = ref NoFs - let stringatom = ref 31 - let curcurs = ref CURSOR_TEXT - let capslmask = ref 0 - let numlmask = ref 0 - let levl3mask = ref 0 - let levl5mask = ref 0 - let xkb = ref false - let fscale = ref 1.0 - let t = ref (object - method display = () - method map (_:bool) = () - method expose = () - method visible (_:visiblestate) = () - method reshape (_:int) (_:int) = () - method mouse (_:int) (_:bool) (_:int) (_:int) (_:int) = () - method motion (_:int) (_:int) = () - method pmotion (_:int) (_:int) = () - method key (_:int) (_:int) = () - method enter (_:int) (_:int) = () - method leave = () - method winstate (_:winstate list) = () - method quit : 'a. 'a = exit 0 - method scroll (_:int) (_:int) = () - method zoom (_:float) (_:int) (_:int) = () - method opendoc (_:string) = () - end) -end - -let settitle s = !S.setwmname (~> s) -let fullscreen () = !S.fullscreen !S.wid -let fontsizescale n = float n *. !S.fscale |> truncate - -let ordermagic = 'l' -let metamask = 0x40 -let altmask = 8 -let shiftmask = 1 -let ctrlmask = 4 - -let withalt mask = mask land altmask != 0 -let withctrl mask = mask land ctrlmask != 0 -let withshift mask = mask land shiftmask != 0 -let withmeta mask = mask land metamask != 0 -let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0 - -let makereq opcode len reqlen = - let s = Bytes.create len in - w8 s 0 opcode; - w16 s 2 reqlen; - s - -let readstr sock n = - let s = Bytes.create n in - let rec loop pos n = - let m = tempfailureretry (Unix.read sock s pos) n in - if m = 0 - then !S.t#quit; - if n != m - then ( - ignore (tempfailureretry (Unix.select [sock] [] []) 0.01); - loop (pos + m) (n - m) - ) - in - loop 0 n; - s - -let sendstr1 s pos len sock = - let s = Bytes.unsafe_to_string s in - vlog "%d <= %S" !S.seq s; - S.seq := !S.seq + 1; - let n = tempfailureretry (Unix.write_substring sock s pos) len in - if n != len - then error "send %d returned %d" len n - -let updkmap sock resp = - let syms = r8 resp 1 in - let len = r32 resp 4 in - let data = - if len > 0 - then readstr sock (4*len) - else E.b - in - let m = len / syms in - S.keymap := Array.make_matrix !S.maxk syms 0xffffff; - let rec loop i = - if i != m - then - let k = i*4*syms in - let rec loop2 k l = - if l != syms - then - let v = r32 data k in - !S.keymap.(i).(l) <- v; - loop2 (k+4) (l+1) - in - loop2 k 0; - loop (i+1); - in - loop 0 - -let updmodmap sock resp = - let n = r8 resp 1 in - let len = r16 resp 4 in - let data = - if len > 0 - then readstr sock (len*4) - else E.b - in - if len > 0 - then (*???*) - let modmap = Array.make_matrix 8 n 0xffffff in - let rec loop l = - if l != 8 - then - let p = l*n in - let rec loop1 m = - if m != n - then - let p = p+m in - let code = r8 data p in - modmap.(l).(m) <- code; - if l = 1 - then ( - let ki = code - !S.mink in - if ki >= 0 - then - let a = !S.keymap.(ki) in - let rec capsloop i = - if not (i = Array.length a || i > 3) - then - let s = a.(i) in - if s = 0xffe5 - then S.capslmask := 2 - else capsloop (i+1) - in - capsloop 0; - ) - else ( - if l > 3 - then - let ki = code - !S.mink in - if ki >= 0 - then - let a = !S.keymap.(ki) in - let rec lloop i = - if not (i = Array.length a || i > 3) - then - let s = a.(i) in - match s with - | 0xfe03 -> S.levl3mask := 1 lsl l - | 0xfe11 -> S.levl5mask := 1 lsl l - | 0xff7f -> S.numlmask := 1 lsl l - | _ -> lloop (i+1) - in - lloop 0; - ); - loop1 (m+1) - in - loop1 0; - loop (l+1) - in - loop 0 - -let sendwithrep sock s f = - Queue.push f !S.fifo; - sendstr1 s 0 (Bytes.length s) sock - -let padcat b1 b2 = - let l1 = Bytes.length b1 and l2 = Bytes.length b2 in - let l = (l1 + l2) land 3 in - let pl = if l > 0 then 4 - l else 0 in - let b = Bytes.create (l1 + l2 + pl) in - Bytes.blit b1 0 b 0 l1; - Bytes.blit b2 0 b l1 l2; - b - -let internreq name onlyifexists = - let s = makereq 16 8 8 in - let s = padcat s name in - w8 s 1 (if onlyifexists then 1 else 0); - w16 s 2 (Bytes.length s / 4); - w16 s 4 (Bytes.length name); - s - -let sendintern sock s onlyifexists f = - let s = internreq s onlyifexists in - sendwithrep sock s f - -let createwindowreq wid parent x y w h bw eventmask vid depth mid = - let s = makereq 1 44 11 in - w8 s 1 depth; - w32 s 4 wid; - w32 s 8 parent; - w16 s 12 x; - w16 s 14 y; - w16 s 16 w; - w16 s 18 h; - w16 s 20 bw; - w16 s 22 0; (* copyfromparent *) - w32 s 24 vid; (* visual *) - w32 s 28 0x2808; (* valuemask = - | border pixel - | event mask - | colormap *) - w32 s 32 0; (* border pixel*) - w32 s 36 eventmask; - w32 s 40 mid; - s - -let createcolormapreq mid wid vid = - let s = makereq 78 16 4 in - w8 s 1 0; - w32 s 4 mid; - w32 s 8 wid; - w32 s 12 vid; - s - -let getgeometryreq wid = - let s = makereq 14 8 2 in - w32 s 4 wid; - s - -let mapreq wid = - let s = makereq 8 8 2 in - w32 s 4 wid; - s - -let getkeymapreq first count = - let s = makereq 101 8 2 in - w8 s 4 first; - w8 s 5 count; - s - -let changepropreq wid prop typ format props = - let s = makereq 18 24 0 in - let s = padcat s props in - w8 s 1 0; - w16 s 2 (Bytes.length s / 4); - w32 s 4 wid; - w32 s 8 prop; - w32 s 12 typ; - w8 s 16 format; - let ful = Bytes.length props / (match format with - | 8 -> 1 - | 16 -> 2 - | 32 -> 4 - | n -> error "no idea what %d means" n) - in - w32 s 20 ful; - s - -let getpropreq delete wid prop typ = - let s = makereq 20 24 6 in - w8 s 1 (if delete then 1 else 0); - w32 s 4 wid; - w32 s 8 prop; - w32 s 12 typ; - w32 s 16 0; - w32 s 20 2; - s - -let configurewindowreq wid mask values = - let s = makereq 12 12 0 in - let s = padcat s values in - w16 s 2 (Bytes.length s / 4); - w32 s 4 wid; - w16 s 8 mask; - s - -let s32 n = - let s = Bytes.create 4 in - w32 s 0 n; - s - -let clientmessage format seq wid typ data = - let s = makereq 33 12 0 in - let s = padcat s data in - w8 s 1 format; - w16 s 2 seq; - w32 s 4 wid; - w32 s 8 typ; - s - -let sendeventreq propagate destwid mask data = - let s = makereq 25 12 11 in - let s = padcat s data in - w8 s 1 propagate; - w16 s 2 11; - w32 s 4 destwid; - w32 s 8 mask; - s - -let getmodifiermappingreq () = - makereq 119 4 1 - -let queryextensionreq name = - let s = makereq 98 8 0 in - let s = padcat s name in - w16 s 2 (Bytes.length s / 4); - w16 s 4 (Bytes.length name); - s - -let getkeysym pkpk code mask = - if (pkpk >= 0xff80 && pkpk <= 0xffbd) - || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff) - then ( - if mask land !S.numlmask != 0 - then - let keysym = !S.keymap.(code - !S.mink).(1) in - if keysym = 0 then pkpk else keysym - else pkpk - ) - else ( - let shift = - if pkpk land 0xf000 = 0xf000 - then 0 - else (mask land 1) lxor ((mask land !S.capslmask) lsr 1) - in - let index = - if !S.xkb && mask land 0x2000 != 0 - then shift + 2 - else - let l3 = (mask land !S.levl3mask) != 0 in - let l4 = (mask land !S.levl5mask) != 0 in - shift + - if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0) - in - let keysym = !S.keymap.(code - !S.mink).(index) in - if index land 1 = 1 && keysym = 0 - then !S.keymap.(code - !S.mink).(index - 1) - else keysym - ) - -let getkeysym code mask = - let pkpk = !S.keymap.(code - !S.mink).(0) in - if !S.xkb && pkpk lsr 8 = 0xfe (* XKB *) - then 0 - else getkeysym pkpk code mask - -let readresp sock = - let resp = readstr sock 32 in - let opcode = r8 resp 0 in - match opcode land lnot 0x80 with - | 0 -> (* error *) - let s = resp in - let code = r8 s 1 - and serial = r16 s 2 - and resid = r32 resp 4 - and min = r16 s 8 - and maj = r8 s 10 in - error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S" - code serial resid min maj (Bytes.unsafe_to_string resp); - - | 1 -> (* response *) - let rep = Queue.pop !S.fifo in - rep resp; - - | 2 -> (* key press *) - if Array.length !S.keymap > 0 - then - let code = r8 resp 1 in - let mask = r16 resp 28 in - let keysym = getkeysym code mask in - vlog "keysym = %x %c mask %#x code %d" - keysym (Char.unsafe_chr keysym) mask code; - if keysym != 0 - then !S.t#key keysym mask; - - | 3 -> (* key release *) - if Array.length !S.keymap > 0 - then - let code = r8 resp 1 in - let mask = r16 resp 28 in - let keysym = getkeysym code mask in - vlog "release keysym = %x %c mask %#x code %d" - keysym (Char.unsafe_chr keysym) mask code; - - | 4 -> (* buttonpress *) - let n = r8 resp 1 - and x = r16s resp 24 - and y = r16s resp 26 - and m = r16 resp 28 in - !S.t#mouse n true x y m; - vlog "press %d" n; - - | 5 -> (* buttonrelease *) - let n = r8 resp 1 - and x = r16s resp 24 - and y = r16s resp 26 - and m = r16 resp 28 in - !S.t#mouse n false x y m; - vlog "release %d %d %d" n x y; - - | 6 -> (* motion *) - let x = r16s resp 24 in - let y = r16s resp 26 in - let m = r16 resp 28 in - if m land 0x1f00 = 0 - then !S.t#pmotion x y - else !S.t#motion x y; - vlog "move %dx%d => %d" x y m; - - | 7 -> (* enter *) - let x = r16s resp 24 - and y = r16s resp 26 in - !S.t#enter x y; - vlog "enter %d %d" x y; - - | 8 -> (* leave *) - !S.t#leave; - - | 18 -> (* unmap *) - !S.t#map false; - vlog "unmap"; - - | 19 -> (* map *) - !S.t#map true; - vlog "map"; - - | 12 -> (* exposure *) - vlog "exposure"; - !S.t#expose; - - | 15 -> (* visibility *) - let v = r8 resp 8 in - let vis = - match v with - | 0 -> Unobscured - | 1 -> PartiallyObscured - | 2 -> FullyObscured - | _ -> - dolog "unknown visibility %d" v; - Unobscured - in - !S.t#visible vis; - vlog "visibility %d" v; - - | 11 -> (* keymapnotify *) - S.keymap := E.a; - let s = getkeymapreq !S.mink (!S.maxk - !S.mink-1) in - sendwithrep sock s (updkmap sock); - S.capslmask := 0; - S.levl3mask := 0; - S.levl5mask := 0; - S.numlmask := 0; - let s = getmodifiermappingreq () in - sendwithrep sock s (updmodmap sock); - - | 33 -> (* clientmessage *) - let atom = r32 resp 8 in - if atom = !S.protoatom - then - let atom = r32 resp 12 in - if atom = !S.deleatom - then !S.t#quit; - vlog "atom %#x" atom; - - | 21 -> (* reparent *) - vlog "reparent"; - - | 22 -> (* configure *) - let x = r16s resp 16 - and y = r16s resp 18 - and w = r16 resp 20 - and h = r16 resp 22 in - vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]" - !S.x !S.y !S.w !S.h - x y w h; - if w != !S.w || h != !S.h - then !S.t#reshape w h; - S.w := w; - S.h := h; - S.x := x; - S.y := y; - - | 24 -> (* Gravity notify *) - (); - - | 28 -> (* Property notify *) - let atom = r32 resp 8 in - if atom = !S.nwmsatom - then - let s = getpropreq false !S.wid atom 4 in - sendwithrep sock s (fun resp -> - S.fs := S.NoFs; - let len = r32 resp 4 in - let nitems = r32 resp 16 in - let wsl = - if len = 0 - then [] - else - let s = readstr sock (len*4) in - let rec loop wsl i = - if i = nitems - then wsl - else - let atom = r32 s (i*4) in - let wsl = - if atom = !S.maxhatom - then MaxHorz::wsl - else ( - if atom = !S.maxvatom - then MaxVert::wsl - else ( - if atom = !S.fulsatom - then ( - S.fs := S.Fs (!S.x, !S.y, !S.w, !S.h); - Fullscreen::wsl - ) - else wsl - ) - ) - in loop wsl (i+1) - in - loop [] 0 - in - !S.t#winstate (List.sort compare wsl) - ); - - | n -> dolog "event %d %S" n (Bytes.unsafe_to_string resp) - -let readresp sock = - let rec loop () = - readresp sock; - if hasdata sock then loop (); - in - loop () - -let sendstr s ?(pos=0) ?(len=Bytes.length s) sock = - sendstr1 s pos len sock; - if hasdata sock then readresp sock - -let reshape w h = - if !S.fs = S.NoFs - then - let s = Bytes.create 8 in - w32 s 0 w; - w32 s 4 h; - let s = configurewindowreq !S.wid 0x000c s in - sendstr s !S.sock; - else !S.fullscreen !S.wid - -let activatewin () = - !S.actwin () - -let syncsendwithrep sock secstowait s f = - let completed = ref false in - sendwithrep sock s (fun resp -> f resp; completed := true); - let now = Unix.gettimeofday in - let deadline = now () +. secstowait in - let rec readtillcompletion () = - let sf deadline = - let timeout = deadline -. now () in - if timeout <= 0.0 - then [], [], [] - else Unix.select [sock] [] [] timeout - in - let r, _, _ = tempfailureretry sf deadline in - match r with - | [] -> error "didn't get X response in %f seconds, aborting" secstowait - | _ -> - readresp sock; - if not !completed - then readtillcompletion (); - in - readtillcompletion () - -let mapwin () = - let s = mapreq !S.wid in - sendstr s !S.sock - -let syncsendintern sock secstowait s onlyifexists f = - let s = internreq s onlyifexists in - syncsendwithrep sock secstowait s f - -let setup disp sock rootwid screennum w h = - let s = readstr sock 2 in - let n = Bytes.length s in - if n != 2 - then error "failed to read X connection setup response n=%d" n; - match Bytes.get s 0 with - | '\000' -> - let reasonlen = r8 s 1 in - let s = readstr sock 6 in - let maj = r16 s 0 - and min = r16 s 2 - and add = r16 s 4 in - let len = add*4 in - let data = readstr sock len in - let reason = Bytes.sub data 0 reasonlen in - error "X connection failed maj=%d min=%d reason=%S" - maj min (Bytes.unsafe_to_string reason); - - | '\002' -> error "X connection setup failed: authentication required"; - - | '\001' -> - let s = readstr sock 38 in - let maj = r16 s 0 - and min = r16 s 2 - and add = r16 s 4 - and idbase = r32 s 10 - and idmask = r32 s 14 - and vlen = r16 s 22 - and screens = r8 s 26 - and formats = r8 s 27 - and minkk = r8 s 32 - and maxkk = r8 s 33 in - let data = readstr sock (4*add-32) in - let vendor = Bytes.sub data 0 vlen in - let pos = ((vlen+3) land lnot 3) + formats*8 in - - if screennum >= screens - then error "invalid screen %d, max %d" screennum (screens-1); - - let pos = - let rec findscreen n pos = - if n = screennum - then pos - else - let pos = - let ndepths = r8 data (pos+39) in - let rec skipdepths n pos = - if n = ndepths - then pos - else - let pos = - let nvisiuals = r16 data (pos+2) in - pos + nvisiuals*24 + 8 - in - skipdepths (n+1) pos - in - skipdepths n (pos+40) - in - findscreen (n+1) pos - in - findscreen 0 pos - in - let root = if rootwid = 0 then r32 data pos else rootwid in - let rootw = r16 data (pos+20) - and rooth = r16 data (pos+22) - and rootdepth = r8 data (pos+38)in - - S.fscale := float rooth /. 1440.0; - S.mink := minkk; - S.maxk := maxkk; - S.idbase := idbase; - vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string vendor) maj min; - vlog "screens = %d formats = %d" screens formats; - vlog "minkk = %d maxkk = %d" minkk maxkk; - vlog "idbase = %#x idmask = %#x" idbase idmask; - vlog "root=%#x %dx%d" root rootw rooth; - vlog "wmm = %d, hmm = %d" (r16 data (pos+24)) (r16 data (pos+26)); - vlog "visualid = %#x" (r32 data (pos+32)); - vlog "root depth = %d" rootdepth; - - let wid = !S.idbase in - let mid = wid+1 in - let fid = mid+1 in - - S.wid := wid; - S.fid := fid; - - let vid = glxinit disp wid screennum in - let ndepths = r8 data (pos+39) in - let rec finddepth n' pos = - if n' = ndepths - then error "cannot find depth for visual %#x" vid; - let depth = r8 data pos in - let nvisuals = r16 data (pos+2) in - let rec findvisual n pos = - if n = nvisuals - then finddepth (n'+1) pos - else - let id = r32 data pos in - if id = vid - then depth - else findvisual (n+1) (pos+24) - in - findvisual 0 (pos+8) - in - let depth = finddepth 0 (pos+40) in - - let s = createcolormapreq mid root vid in - sendstr s sock; - - let mask = 0 - + 0x00000001 (* KeyPress *) - (* + 0x00000002 *) (* KeyRelease *) - + 0x00000004 (* ButtonPress *) - + 0x00000008 (* ButtonRelease *) - + 0x00000010 (* EnterWindow *) - + 0x00000020 (* LeaveWindow *) - + 0x00000040 (* PointerMotion *) - (* + 0x00000080 *) (* PointerMotionHint *) - (* + 0x00000100 *) (* Button1Motion *) - (* + 0x00000200 *) (* Button2Motion *) - (* + 0x00000400 *) (* Button3Motion *) - (* + 0x00000800 *) (* Button4Motion *) - (* + 0x00001000 *) (* Button5Motion *) - + 0x00002000 (* ButtonMotion *) - + 0x00004000 (* KeymapState *) - + 0x00008000 (* Exposure *) - + 0x00010000 (* VisibilityChange *) - + 0x00020000 (* StructureNotify *) - (* + 0x00040000 *) (* ResizeRedirect *) - (* + 0x00080000 *) (* SubstructureNotify *) - (* + 0x00100000 *) (* SubstructureRedirect *) - (* + 0x00200000 *) (* FocusChange *) - + 0x00400000 (* PropertyChange *) - (* + 0x00800000 *) (* ColormapChange *) - (* + 0x01000000 *) (* OwnerGrabButton *) - in - - let s = createwindowreq wid root 0 0 w h 0 mask vid depth mid in - sendstr s sock; - - sendintern - sock (~> "WM_PROTOCOLS") false (fun resp -> - S.protoatom := r32 resp 8; - sendintern - sock (~> "WM_DELETE_WINDOW") false (fun resp -> - S.deleatom := r32 resp 8; - let s = s32 !S.deleatom in - let s = changepropreq wid !S.protoatom 4 32 s in - sendstr s sock; - ); - ); - - sendintern - sock (~> "WM_CLIENT_MACHINE") false (fun resp -> - let atom = r32 resp 8 in - let empty = E.s in - let hostname = - try Unix.gethostname () - with exn -> - dolog "error getting host name: %s" @@ exntos exn; - empty - in - if hostname != empty - then - let s = changepropreq wid atom !S.stringatom 8 - (~> hostname) in - sendstr s sock; - sendintern - sock (~> "_NET_WM_PID") false (fun resp -> - let atom = r32 resp 8 in - let pid = Unix.getpid () in - let s = s32 pid in - let s = changepropreq wid atom 6(*cardinal*) 32 s in - sendstr s sock; - ) - ); - - S.actwin := (fun () -> - let s = Bytes.create 4 in - let s = configurewindowreq wid 0x40 s in - sendstr s !S.sock; - let s = mapreq wid in - sendstr s !S.sock; - ); - - sendintern - sock (~> "_NET_ACTIVE_WINDOW") true (fun resp -> - let atom = r32 resp 8 in - S.actwin := (fun () -> - let data = Bytes.make 20 '\000' in - let cm = clientmessage 32 0 wid atom data in - let s = sendeventreq 0 root 0x180000 cm in - sendstr s !S.sock; - ); - ); - - syncsendintern - sock 2.0 (~> "WM_CLASS") false (fun resp -> - let atom = r32 resp 8 in - let llpp = ~> "llpp\000llpp\000" in - let s = changepropreq wid atom 31 8 llpp in - sendstr s sock; - ); - - let s = getkeymapreq !S.mink (!S.maxk - !S.mink) in - sendwithrep sock s (updkmap sock); - - let s = getmodifiermappingreq () in - sendwithrep sock s (updmodmap sock); - - sendintern - sock (~> "UTF8_STRING") true (fun resp -> - let atom = r32 resp 8 in - if atom != 0 - then S.stringatom := atom; - ); - - let setwmname s = - let s = changepropreq wid 39 !S.stringatom 8 s in - sendstr s !S.sock; - in - S.setwmname := setwmname; - sendintern - sock (~> "_NET_WM_NAME") true (fun resp -> - let atom = r32 resp 8 in - if atom != 0 - then S.setwmname := (fun s -> - setwmname s; - let s = changepropreq wid atom !S.stringatom 8 s in - sendstr s !S.sock; - ); - ); - - sendintern - sock (~> "_NET_WM_STATE") true (fun resp -> - S.nwmsatom := r32 resp 8; - if !S.nwmsatom != 0 - then ( - sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp -> - S.maxvatom := r32 resp 8; - ); - sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp -> - S.maxhatom := r32 resp 8; - ); - sendintern - sock (~> "_NET_WM_STATE_FULLSCREEN") false (fun resp -> - S.fulsatom := r32 resp 8; - if !S.fulsatom != 0 - then - S.fullscreen := - (fun wid -> - let data = Bytes.make 20 '\000' in - let fs, f = - match !S.fs with - | S.NoFs -> S.Fs (-1, -1, -1, -1), 1 - | S.Fs _ -> S.NoFs, 0 - in - w32 data 0 f; - w32 data 4 !S.fulsatom; - - let cm = clientmessage 32 0 wid !S.nwmsatom data in - let s = sendeventreq 0 root 0x180000 cm in - sendstr s sock; - S.fs := fs; - ); - ); - ); - ); - let s = queryextensionreq (~> "XKEYBOARD") in - sendwithrep - sock s (fun resp -> - let present = r8 resp 8 in - if present != 0 - then ( - let maj = r8 resp 9 in - let s = Bytes.create 8 in - w8 s 0 maj; (* XKB *) - w8 s 1 0; (* XKBUseExtension *) - w16 s 2 2; (* request-length *) - w16 s 4 1; (* wantedMajor *) - w16 s 6 0; (* watnedMinor *) - sendwithrep - sock s - (fun resp -> - let supported = r8 resp 1 in - S.xkb := supported != 0 - ) - ); - ); - let s = getgeometryreq wid in - syncsendwithrep sock 2.0 s (fun resp -> - glxcompleteinit (); - let w = r16 resp 16 - and h = r16 resp 18 in - S.w := w; - S.h := h; - ); - - | c -> error "unknown connection setup response %d" (Char.code c) - -let getauth haddr dnum = - let haddr = - if emptystr haddr || haddr = "localhost" - then - try Unix.gethostname () - with exn -> - dolog "failed to resolve `%S': %s" haddr @@ exntos exn; - haddr - else haddr - in - let path, warn = - try Sys.getenv "XAUTHORITY", true - with Not_found -> - try Filename.concat (Sys.getenv "HOME") ".Xauthority", false - with Not_found -> E.s, false - in - let readauth ic = - let r16be s = - let rb pos = Char.code (Bytes.get s pos) in - (rb 1) lor ((rb 0) lsl 8) - in - let rec find () = - let rs () = - let s = really_input_string ic 2 in - let n = r16be (~> s) in - really_input_string ic n - in - let family = really_input_string ic 2 in - let addr = rs () in - let nums = rs () in - let optnum = - match int_of_string nums with - | n -> Some n - | exception exn -> - if nonemptystr nums - then - dolog "display number(%S) is not an integer (corrupt %S?): %s" - nums path @@ exntos exn - ; - None - in - let name = rs () in - let data = rs () in - - vlog "family %S addr %S(%S) num %S(%d) name %S data %S" - family addr haddr nums dnum name data; - match optnum with - | Some num when addr = haddr && num = dnum -> - name, data - | _ -> find () - in - let name, data = - try find () - with - | End_of_file -> E.s, E.s - | exn -> - dolog "exception while reading X authority data (%S): %s" - path @@ exntos exn; - E.s, E.s - in - close_in ic; - name, data; - in - if emptystr path - then E.s, E.s - else - match open_in_bin path with - | ic -> readauth ic - | exception exn -> - if warn - then - dolog "failed to open X authority file `%S' : %s" path @@ exntos exn - ; - E.s, E.s - -let init t w h = - let d = - try Sys.getenv "DISPLAY" - with exn -> - error "cannot get DISPLAY evironment variable: %s" @@ exntos exn - in - let getnum w b e = - if b = e - then error "invalid DISPLAY(%s) %S" w d - else - let s = String.sub d b (e - b) in - try int_of_string s - with exn -> - error "invalid DISPLAY %S can not parse %s(%S): %s" d w s @@ exntos exn - in - let rec phost pos = - if pos = String.length d - then error "invalid DISPLAY %S no display number specified" d - else ( - if d.[pos] = ':' - then - let rec pdispnum pos1 = - if pos1 = String.length d - then getnum "display number" (pos+1) pos1, 0 - else - match d.[pos1] with - | '.' -> - let dispnum = getnum "display number" (pos+1) pos1 in - let rec pscreennum pos2 = - if pos2 = String.length d - then getnum "screen number" (pos1+1) pos2 - else - match d.[pos2] with - | '0' .. '9' -> pscreennum (pos2+1) - | _ -> - error "invalid DISPLAY %S, cannot parse screen number" d - in - dispnum, pscreennum (pos1+1) - | '0' .. '9' -> pdispnum (pos1+1) - | _ -> error "invalid DISPLAY %S, cannot parse display number" d - in - String.sub d 0 pos, pdispnum (pos+1) - else phost (pos+1) - ) - in - let host, (dispnum, screennum) = phost 0 in - let aname, adata = getauth host dispnum in - let fd = - let fd, addr = - if emptystr host || host.[0] = '/' || host = "unix" - then - (Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0, - Unix.ADDR_UNIX ("\000/tmp/.X11-unix/X" ^ string_of_int dispnum)) - else - let h = - try Unix.gethostbyname host - with exn -> error "cannot resolve %S: %s" host @@ exntos exn - in - let addr = h.Unix.h_addr_list.(0) in - let port = 6000 + dispnum in - let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - fd, (Unix.ADDR_INET (addr, port)) - in - try Unix.connect fd addr; fd - with exn -> error "failed to connect to X: %s" @@ exntos exn - in - Unix.set_close_on_exec fd; - let s = Bytes.create 12 in - let s = padcat s (~> aname) in - let s = padcat s (~> adata) in - Bytes.set s 0 ordermagic; - w16 s 2 11; - w16 s 4 0; - w16 s 6 (String.length aname); - w16 s 8 (String.length adata); - sendstr1 s 0 (Bytes.length s) fd; - S.sock := fd; - setup d fd 0 screennum w h; - S.t := t; - fd, !S.w, !S.h - -let setcursor cursor = - if cursor != !S.curcurs - then ( - setcursor cursor; - S.curcurs := cursor; - ) - -let xlatt, xlatf = - let t = Hashtbl.create 20 - and f = Hashtbl.create 20 in - let add n nl k = - List.iter (fun s -> Hashtbl.add t s k) (n::nl); - Hashtbl.add f k n - in - let addc c = - let s = String.make 1 c in - add s [] (Char.code c) - in - let addcr a b = - let an = Char.code a and bn = Char.code b in - for i = an to bn do addc (Char.chr i) done; - in - addcr '0' '9'; - addcr 'a' 'z'; - addcr 'A' 'Z'; - String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?"; - for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done; - add "space" [] 0x20; - add "ret" ["return"; "enter"] 0xff0d; - add "tab" [] 0xff09; - add "left" [] 0xff51; - add "right" [] 0xff53; - add "home" [] 0xff50; - add "end" [] 0xff57; - add "ins" ["insert"] 0xff63; - add "del" ["delete"] 0xffff; - add "esc" ["escape"] 0xff1b; - add "pgup" ["pageup"] 0xff55; - add "pgdown" ["pagedown"; "pgdn"] 0xff56; - add "backspace" [] 0xff08; - add "up" [] 0xff52; - add "down" [] 0xff54; - add "menu" [] 0xff67; - t, f - -let keyname k = - try Hashtbl.find xlatf k - with Not_found -> Printf.sprintf "%#x" k - -let namekey name = - try Hashtbl.find xlatt name - with Not_found -> - if String.length name = 1 - then Char.code name.[0] - else int_of_string name - -let ks2kt = - let open Keys in - function - | 0xff08 -> Backspace - | 0xff0d -> Enter - | 0xff1b -> Escape - | 0xff50 -> Home - | 0xff51 -> Left - | 0xff52 -> Up - | 0xff53 -> Right - | 0xff54 -> Down - | 0xff55 -> Prior - | 0xff56 -> Next - | 0xff57 -> End - | 0xff63 -> Insert - | 0xff8d -> Enter - | 0xff95 -> Home - | 0xff96 -> Left - | 0xff97 -> Up - | 0xff98 -> Right - | 0xff99 -> Down - | 0xff9a -> Prior - | 0xff9b -> Next - | 0xff9c -> End - | 0xff9f -> Delete - | 0xffab -> Ascii '+' - | 0xffad -> Ascii '-' - | 0xffff -> Delete - | code when code > 31 && code < 128 -> Ascii (Char.unsafe_chr code) - | code when code >= 0xffb0 && code <= 0xffb9 -> - Ascii (Char.unsafe_chr (code - 0xffb0 + 0x30)) - | code when code >= 0xffbe && code <= 0xffc8 -> Fn (code - 0xffbe + 1) - | code when code land 0xff00 = 0xff00 -> Ctrl code - | code -> Code code - -let cAp = "https://github.com/astrand/xclip" diff --git a/wsi/x11/wsi.mli b/wsi/x11/wsi.mli deleted file mode 100644 index a27ba15..0000000 --- a/wsi/x11/wsi.mli +++ /dev/null @@ -1,60 +0,0 @@ -type cursor = - | CURSOR_INHERIT - | CURSOR_INFO - | CURSOR_CYCLE - | CURSOR_FLEUR - | CURSOR_TEXT - -type winstate = - | MaxVert - | MaxHorz - | Fullscreen - -type visiblestate = - | Unobscured - | PartiallyObscured - | FullyObscured - -class type t = - object - method display : unit - method map : bool -> unit - method expose : unit - method visible : visiblestate -> unit - method reshape : int -> int -> unit - method mouse : int -> bool -> int -> int -> int -> unit - method motion : int -> int -> unit - method pmotion : int -> int -> unit - method key : int -> int -> unit - method enter : int -> int -> unit - method leave : unit - method winstate : winstate list -> unit - method quit : 'a. 'a - method scroll : int -> int -> unit - method zoom : float -> int -> int -> unit - method opendoc : string -> unit - end - -val setcursor : cursor -> unit -val settitle : string -> unit -val swapb : unit -> unit -val readresp : Unix.file_descr -> unit -val init : t -> int -> int -> Unix.file_descr * int * int -val fullscreen : unit -> unit -val reshape : int -> int -> unit -val activatewin : unit -> unit -val mapwin : unit -> unit -val withalt : int -> bool -val withctrl : int -> bool -val withshift : int -> bool -val withmeta : int -> bool -val withnone : int -> bool -val metamask : int -val altmask : int -val shiftmask : int -val ctrlmask : int -val keyname : int -> string -val namekey : string -> int -val fontsizescale : int -> int -val ks2kt : int -> Keys.t -val cAp : string diff --git a/wsi/x11/xlib.c b/wsi/x11/xlib.c deleted file mode 100644 index 04f8fbc..0000000 --- a/wsi/x11/xlib.c +++ /dev/null @@ -1,92 +0,0 @@ -#define CAML_NAME_SPACE - -#include -#include - -#include - -#include -#include -#include -#include - -static const int shapes[] = { - XC_left_ptr, XC_hand2, XC_exchange, XC_fleur, XC_xterm -}; - -#define CURS_COUNT (sizeof (shapes) / sizeof (shapes[0])) - -static struct { - Window wid; - Display *dpy; - GLXContext ctx; - XVisualInfo *visual; - Cursor curs[CURS_COUNT]; -} glx; - -static void initcurs (void) -{ - for (size_t n = 0; n < CURS_COUNT; ++n) { - glx.curs[n] = XCreateFontCursor (glx.dpy, shapes[n]); - } -} - -CAMLprim value ml_glxinit (value display_v, value wid_v, value screen_v) -{ - CAMLparam3 (display_v, wid_v, screen_v); - - glx.dpy = XOpenDisplay (String_val (display_v)); - if (!glx.dpy) { - caml_failwith ("XOpenDisplay"); - } - - int attribs[] = { GLX_RGBA, GLX_DOUBLEBUFFER, None }; - glx.visual = glXChooseVisual (glx.dpy, Int_val (screen_v), attribs); - if (!glx.visual) { - XCloseDisplay (glx.dpy); - caml_failwith ("glXChooseVisual"); - } - - initcurs (); - - glx.wid = Int_val (wid_v); - CAMLreturn (Val_int (glx.visual->visualid)); -} - -CAMLprim void ml_glxcompleteinit (void) -{ - glx.ctx = glXCreateContext (glx.dpy, glx.visual, NULL, True); - if (!glx.ctx) { - caml_failwith ("glXCreateContext"); - } - - XFree (glx.visual); - glx.visual = NULL; - - if (!glXMakeCurrent (glx.dpy, glx.wid, glx.ctx)) { - glXDestroyContext (glx.dpy, glx.ctx); - glx.ctx = NULL; - caml_failwith ("glXMakeCurrent"); - } -} - -CAMLprim void ml_setcursor (value cursor_v) -{ - CAMLparam1 (cursor_v); - size_t cursn = Int_val (cursor_v); - - if (cursn >= CURS_COUNT) caml_failwith ("cursor index out of range"); - XDefineCursor (glx.dpy, glx.wid, glx.curs[cursn]); - XFlush (glx.dpy); - CAMLreturn0; -} - -CAMLprim void ml_swapb (void) -{ - glXSwapBuffers (glx.dpy, glx.wid); -} - -void (*wsigladdr (const char *name)) (void) -{ - return glXGetProcAddress ((const GLubyte *) name); -} -- 2.11.4.GIT