├── .gitignore ├── .travis-ci.sh ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── apps ├── jbuild ├── wavedraw.ml ├── waveterm.ml └── waveterm_fs.ml ├── hardcaml-waveterm.opam ├── jbuild ├── src ├── META ├── api.ml.old ├── gfx.ml ├── gfx.mli ├── gfx_lterm.ml ├── gfx_lterm.mli ├── jbuild ├── lTerm_waveterm_compat.ml ├── render.ml ├── render.mli ├── sim.ml ├── sim.mli ├── ui.ml ├── ui.mli ├── wave.ml ├── wave.mli ├── widget.ml ├── widget.mli ├── write.ml └── write.mli └── test ├── data-render.wave ├── genwave.ml ├── index.html ├── jbuild ├── testsim.ml ├── testsim_lwt.ml ├── testwidget.ml ├── testwidget_lwt.ml ├── toggle.wave ├── wave-scroll.html ├── wave-static.html └── wave.txt /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .*.swp 3 | *~ 4 | .merlin 5 | *.install 6 | -------------------------------------------------------------------------------- /.travis-ci.sh: -------------------------------------------------------------------------------- 1 | # install OCaml + OPAM 2 | case "$OCAML_VERSION,$OPAM_VERSION" in 3 | 3.12.1,1.0.0) ppa=avsm/ocaml312+opam10 ;; 4 | 3.12.1,1.1.0) ppa=avsm/ocaml312+opam11 ;; 5 | 4.00.1,1.0.0) ppa=avsm/ocaml40+opam10 ;; 6 | 4.00.1,1.1.0) ppa=avsm/ocaml40+opam11 ;; 7 | 4.01.0,1.0.0) ppa=avsm/ocaml41+opam10 ;; 8 | 4.01.0,1.1.0) ppa=avsm/ocaml41+opam11 ;; 9 | 4.01.0,1.2.0) ppa=avsm/ocaml41+opam12 ;; 10 | 4.02.1,1.2.0) ppa=avsm/ocaml42+opam12 ;; 11 | 4.02.3,1.2.0) ppa=avsm/ocaml42+opam12 ;; 12 | *) echo Unknown $OCAML_VERSION,$OPAM_VERSION; exit 1 ;; 13 | esac 14 | 15 | echo "yes" | sudo add-apt-repository ppa:$ppa 16 | sudo apt-get update -qq 17 | sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam 18 | 19 | export OPAMYES=1 20 | opam init 21 | eval `opam config env` 22 | 23 | opam pin add -n $OPAMPKG -k git . 24 | opam depext -y $DEPPKGS $OPAMPKG 25 | 26 | opam install $DEPPKGS $OPAMPKG 27 | 28 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | script: bash -ex .travis-ci.sh 4 | env: 5 | - OCAML_VERSION=4.02.3 OPAM_VERSION=1.2.0 OPAMPKG=hardcaml-waveterm DEPPKGS="" 6 | 7 | 8 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # v0.2.2 2 | 3 | * opam-publish 4 | 5 | # v0.2.1 6 | 7 | * Remove camlp4 - port to ppx 8 | 9 | # v0.2.0 10 | 11 | * Merge HardCamlWaveTerm and HardCamlWaveLTerm 12 | * Add new waveterm viewer interface based on lambda-term widgets 13 | 14 | # v0.1.0 15 | 16 | * Initial version. 17 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, MicroJamJar Ltd 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: test apps build 2 | all: build 3 | 4 | build: 5 | jbuilder build @install 6 | 7 | tests: build 8 | jbuilder build @tests 9 | 10 | apps: build 11 | jbuilder build @apps 12 | 13 | clean: 14 | rm -fr _build 15 | 16 | VERSION := $$(opam query --version) 17 | NAME_VERSION := $$(opam query --name-version) 18 | ARCHIVE := $$(opam query --archive) 19 | 20 | tag: 21 | git tag -a "v$(VERSION)" -m "v$(VERSION)." 22 | git push origin v$(VERSION) 23 | 24 | prepare: 25 | opam publish prepare -r hardcaml $(NAME_VERSION) $(ARCHIVE) 26 | 27 | publish: 28 | opam publish submit -r hardcaml $(NAME_VERSION) 29 | rm -rf $(NAME_VERSION) 30 | 31 | 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Waveform viewer library for HardCaml 2 | 3 | [![Build Status](https://travis-ci.org/ujamjar/hardcaml-waveterm.svg?branch=master)](https://travis-ci.org/ujamjar/hardcaml-waveterm) 4 | 5 | A text (unicode) based digital waveform viewer library. 6 | 7 | ## Features 8 | 9 | * `waveterm` an interactive viewer 10 | * `wavedraw` render to text or html documents 11 | * integrated with HardCaml simulations 12 | 13 | ## Examples 14 | 15 | * [UTF-8 output](https://raw.githubusercontent.com/ujamjar/hardcaml-wave-term/master/test/wave.txt) 16 | 17 | ``` 18 | $ wavedraw -o test/wave.txt data.wave 19 | ``` 20 | * [Basic HTML output](http://www.ujamjar.com/hardcaml/wave-term/wave-static.html) 21 | 22 | ``` 23 | $ wavedraw -html static -o test/wave-static.html data.wave 24 | ``` 25 | 26 | * [Styled HTML output with scrolling](http://www.ujamjar.com/hardcaml/wave-term/wave-scroll.html) 27 | 28 | ``` 29 | $ wavedraw -html scroll -o test/wave-scroll.html data.wave 30 | ``` 31 | 32 | ## TODO 33 | 34 | ### General 35 | 36 | * [ ] Interactive javascript version 37 | * [ ] check html rendering on different browsers (mobile chrome known dodgy) 38 | 39 | ## Interactive app 40 | 41 | * [ ] resize sub-windows 42 | * [ ] interactive testbench driver mode (edit signal values, send back to simulation) 43 | -------------------------------------------------------------------------------- /apps/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((names (wavedraw waveterm waveterm_fs)) 5 | (libraries (hardcaml-waveterm)) 6 | (preprocess (action (run bodge_ppx.sh ppx_lwt ${<}))))) 7 | 8 | -------------------------------------------------------------------------------- /apps/wavedraw.ml: -------------------------------------------------------------------------------- 1 | (* HTML or UFT-8 file generation with various options *) 2 | open HardCamlWaveTerm 3 | 4 | let help = 5 | "Wave draw 6 | ========= 7 | 8 | Render HardCaml digital waveform files into UTF-8 text or 9 | HTML Files. 10 | 11 | $ " ^ Sys.argv.(0) ^ " {[options] [-o file-out] file-in}* 12 | 13 | By default output is written as UTF-8 without any styling. 14 | This is suitable for loading into editors. Enable 15 | styling with '-styler term' (view with 'less -r file'). 16 | 17 | Static or scrollable HTML output can be selected with 18 | the '-html' option. Styling is enabled with the 'css' 19 | or 'class' styler options. 20 | 21 | Mutliple outputs can be generated. This happens 22 | whenever a file-in argument is read. Therefore, 23 | the output file, if any, and arguments must be specified 24 | before the corresponding input file. 25 | 26 | The output file and mode are reset to stdout and UTF-8 27 | between each invocation. ie 28 | 29 | $ " ^ Sys.argv.(0) ^ " a.wave -html static -o b.html b.wave c.wave 30 | 31 | will (1) display a.wave on stdout (2) write b.html from b.wave 32 | (3) display c.wave on stdout. 33 | " 34 | 35 | type mode = Utf8 | Html | Html_scroll 36 | 37 | type styler = No_style | Css | Css_class | Term 38 | 39 | (* command line *) 40 | let rows, cols = ref 0, ref 80 41 | let width, height = ref 3, ref 1 42 | let start_cycle, start_signal = ref 0, ref 0 43 | let cursor = ref (-1) 44 | let styler = ref No_style 45 | let scheme = ref Render.Styles.colour_on_black 46 | let mode = ref Utf8 47 | let out_file = ref "" 48 | 49 | let reset_state () = mode := Utf8; out_file := "" 50 | 51 | module B = HardCaml.Bits.Comb.IntbitsList 52 | module W = Wave.Make(Wave.Bits(B)) 53 | module G = Gfx.In_memory.Api 54 | module R = Render.Static(W) 55 | open Gfx 56 | open G 57 | 58 | (* static user interface *) 59 | let draw_static waves = 60 | R.draw ~style:!scheme 61 | ?rows:(if !rows=0 then None else Some(!rows)) 62 | ~cols:!cols waves 63 | 64 | (* draw everything at full size *) 65 | let draw_scroll waves = 66 | let sctx, _, wctx = R.draw_full ~style:!scheme waves in 67 | sctx, wctx 68 | 69 | let get_waves name = 70 | let f = open_in name in 71 | let w = W.read f in 72 | close_in f; 73 | w 74 | 75 | let gen name = begin 76 | (* set up output file *) 77 | let os, close = 78 | if !out_file = "" then 79 | print_string, (fun () -> ()) 80 | else 81 | let f = open_out !out_file in 82 | output_string f, (fun () -> close_out f) 83 | in 84 | let waves = W.({ (get_waves name) with 85 | cfg = { default with (* XXX live with warning for now ... *) 86 | wave_width = !width; 87 | wave_height = !height; 88 | start_cycle = !start_cycle; 89 | start_signal = !start_signal; 90 | wave_cursor = !cursor; 91 | } 92 | }) in 93 | let style_fn = 94 | match !styler with 95 | | No_style -> Write.no_styler 96 | | Term -> Write.term_styler 97 | | Css -> Write.html_styler 98 | | Css_class -> Write.css_class_styler 99 | in 100 | 101 | let html_header () = 102 | if !styler = Css_class then begin 103 | (* write embedded css classes *) 104 | os 105 | ("\n") 108 | end else begin 109 | os "\n"; 110 | end; 111 | in 112 | 113 | begin 114 | match !mode with 115 | | Utf8 -> begin 116 | (* write utf-8 *) 117 | let ctx = draw_static waves in 118 | Write.utf8 ~styler:style_fn os ctx 119 | end 120 | | Html -> begin 121 | (* write html file *) 122 | let ctx = draw_static waves in 123 | html_header (); 124 | os "
\n";
125 |       Write.html_escape ~styler:style_fn os ctx;
126 |       os "
" 127 | end 128 | | Html_scroll -> begin 129 | (* write html file with signals and waves as floating divs with scroll bars. 130 | * bit of a hack for the width %'s. Not really sure how its supposed to 131 | * work, but it seems to be OK. *) 132 | let sctx, wctx = draw_scroll waves in 133 | let div_style = 134 | "display:inline-block; overflow-x:auto; float:left" 135 | in 136 | 137 | html_header (); 138 | os "\n"; 139 | os "
"; 140 | os ("
");
141 |       Write.html_escape ~styler:style_fn os sctx;
142 |       os "
\n"; 143 | os ("
");
144 |       Write.html_escape ~styler:style_fn os wctx;
145 |       os "
\n"; 146 | os "
"; 147 | os ""; 148 | end 149 | end; 150 | (* reset out file and mode, carry over various styling infos *) 151 | close (); reset_state () 152 | end 153 | 154 | let () = 155 | if Array.length Sys.argv = 1 then print_string help 156 | else Arg.parse 157 | [ 158 | "-rows", Arg.Set_int rows, "number of rows"; 159 | "-cols", Arg.Set_int cols, "number of cols"; 160 | "-width", Arg.Set_int width, "wave cycle width"; 161 | "-height", Arg.Set_int height, "wave cycle height"; 162 | "-cycle", Arg.Set_int start_cycle, "wave start cycle"; 163 | "-signal", Arg.Set_int start_signal, "wave start signal"; 164 | "-cursor", Arg.Set_int cursor, "cursor"; 165 | "-styler", Arg.Symbol(["none"; "term"; "css"; "class"], 166 | (function 167 | | "term" -> styler := Term 168 | | "css" -> styler := Css 169 | | "class" -> styler := Css_class 170 | | "none" -> styler := No_style 171 | | _ -> ())), " select style generator"; 172 | "-style", Arg.Symbol(["white"; "black"; "light"; "dark"], 173 | (function 174 | | "white" -> scheme := Render.Styles.black_on_white 175 | | "black" -> scheme := Render.Styles.white_on_black 176 | | "light" -> scheme := Render.Styles.colour_on_white 177 | | "dark" -> scheme := Render.Styles.colour_on_black 178 | | _ -> ())), " select colour scheme"; 179 | "-html", Arg.Symbol(["static"; "scroll"], 180 | (function 181 | | "static" -> mode := Html 182 | | "scroll" -> mode := Html_scroll 183 | | _ -> ())), " HTML generation"; 184 | "-o", Arg.Set_string out_file, "output file (default stdout)"; 185 | ] 186 | gen help 187 | 188 | -------------------------------------------------------------------------------- /apps/waveterm.ml: -------------------------------------------------------------------------------- 1 | let help = 2 | "Wave viewer 3 | =========== 4 | 5 | View HardCaml digital waveform files. 6 | 7 | $ " ^ Sys.argv.(0) ^ " [file...] 8 | 9 | Controls 10 | -------- 11 | 12 | ESC Quit 13 | +/- Scale wave width 14 | +/- Scale wave height 15 | 16 | Scroll up/down 17 | + Scroll left/right 18 | Set cursor 19 | Scroll to wave 20 | " 21 | open Lwt 22 | open LTerm_geom 23 | open LTerm_key 24 | open CamomileLibrary 25 | 26 | open HardCamlWaveTerm 27 | 28 | module B = HardCaml.Bits.Comb.IntbitsList 29 | module W = Wave.Make(HardCamlWaveTerm.Wave.Bits(B)) 30 | module Widget = HardCamlWaveTerm.Widget.Make(B)(W) 31 | 32 | let num_files = Array.length Sys.argv - 1 33 | 34 | let () = if num_files < 1 then begin 35 | Printf.eprintf "No files specified"; 36 | exit (-1) 37 | end 38 | 39 | let get_waves name = 40 | let f = open_in name in 41 | let w = W.read f in 42 | close_in f; 43 | w 44 | 45 | let file_index = ref 0 46 | let get_file idx = Sys.argv.(1 + idx) 47 | let next () = (!file_index+1) mod num_files 48 | let prev () = (!file_index+num_files-1) mod num_files 49 | 50 | let run () = 51 | let waiter, wakener = wait () in 52 | let waves = get_waves (get_file !file_index) in 53 | let waveform = new Widget.waveform () in 54 | waveform#set_waves waves; 55 | 56 | let buttons = 57 | let hbox = new LTerm_widget.hbox in 58 | let left = new LTerm_waveterm_compat.Button.button ~brackets:("<-- ","") (get_file (prev ())) in 59 | let right = new LTerm_waveterm_compat.Button.button ~brackets:(""," -->") (get_file (next ())) in 60 | let exit = new LTerm_widget.button "exit" in 61 | let click f = 62 | file_index := f (); 63 | waveform#set_waves ~keep_cfg:true (get_waves (get_file !file_index)); 64 | left#set_label (get_file (prev ())); 65 | right#set_label (get_file (next ())) 66 | in 67 | left#on_click (fun () -> click prev); 68 | right#on_click (fun () -> click next); 69 | exit#on_click (wakeup wakener); 70 | hbox#add left; 71 | hbox#add ~expand:false exit; 72 | hbox#add right; 73 | hbox 74 | in 75 | 76 | let top = new LTerm_widget.vbox in 77 | top#add waveform; 78 | top#add ~expand:false (new LTerm_widget.hline); 79 | top#add ~expand:false buttons; 80 | 81 | top#on_event (function 82 | LTerm_event.Key{LTerm_key.code=LTerm_key.Escape} -> 83 | wakeup wakener (); false | _ -> false); 84 | 85 | Lazy.force LTerm.stdout >>= fun term -> 86 | LTerm.enable_mouse term >>= fun () -> 87 | Lwt.finalize 88 | (fun () -> LTerm_widget.run term top waiter) 89 | (fun () -> LTerm.disable_mouse term) 90 | 91 | let%lwt () = run () 92 | 93 | -------------------------------------------------------------------------------- /apps/waveterm_fs.ml: -------------------------------------------------------------------------------- 1 | let help = 2 | "Wave viewer 3 | =========== 4 | 5 | View HardCaml digital waveform file. 6 | 7 | $ " ^ Sys.argv.(0) ^ " [options] file 8 | 9 | Controls 10 | -------- 11 | 12 | q/esc Quit 13 | +/- Scale wave width 14 | +/- Scale wave height 15 | / Scroll wave ( x 10) 16 | / Scroll names and values 17 | 18 | Set cursor 19 | Scroll to wave 20 | " 21 | open Lwt 22 | open LTerm_geom 23 | open LTerm_key 24 | open CamomileLibrary 25 | 26 | open HardCamlWaveTerm 27 | 28 | module B = HardCaml.Bits.Comb.IntbitsList 29 | module W = Wave.Make(HardCamlWaveTerm.Wave.Bits(B)) 30 | module Ui = HardCamlWaveLTerm.Ui.Make(B)(W) 31 | 32 | let scheme = ref Render.Styles.colour_on_black 33 | let files = ref [] 34 | 35 | let () = Arg.parse 36 | [ 37 | "-style", Arg.Symbol(["white"; "black"; "light"; "dark"], 38 | (function 39 | | "white" -> scheme := Render.Styles.black_on_white 40 | | "black" -> scheme := Render.Styles.white_on_black 41 | | "light" -> scheme := Render.Styles.colour_on_white 42 | | "dark" -> scheme := Render.Styles.colour_on_black 43 | | _ -> ())), " select colour scheme"; 44 | ] 45 | (fun s -> files := s :: !files) help 46 | 47 | let get_waves name = 48 | let f = open_in name in 49 | let w = W.read f in 50 | close_in f; 51 | w 52 | 53 | let run file = 54 | let waves = get_waves file in 55 | Ui.run ~style:!scheme waves 56 | 57 | lwt () = 58 | match !files with 59 | | [a] -> run a 60 | | _ -> Lwt_io.printf "Specify 1 file to render\n" 61 | 62 | -------------------------------------------------------------------------------- /hardcaml-waveterm.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "andy.ray@ujamjar.com" 3 | authors: "andy.ray@ujamjar.com" 4 | homepage: "https://github.com/ujamjar/hardcaml-waveterm" 5 | dev-repo: "https://github.com/ujamjar/hardcaml-waveterm.git" 6 | bug-reports: "https://github.com/ujamjar/hardcaml-waveterm/issues" 7 | build: [ ["jbuilder" "build" "-p" name "-j" jobs] ] 8 | depends: [ 9 | "ocamlfind" {build} 10 | "jbuilder" {build & >= "1.0+beta8"} 11 | "hardcaml" { >= "1.2.0" & < "2.0.0" } 12 | "astring" 13 | "lambda-term" 14 | "lwt" { >= "2.6.0" } 15 | ] 16 | available: [ ocaml-version >= "4.02.3" ] 17 | name: "hardcaml-waveterm" 18 | version: "0.3.0" 19 | license: "ISC" 20 | 21 | -------------------------------------------------------------------------------- /jbuild: -------------------------------------------------------------------------------- 1 | (alias 2 | ((name apps) 3 | (deps (apps/wavedraw.exe apps/waveterm.exe)))) 4 | 5 | (alias 6 | ((name tests) 7 | (deps (test/testsim.exe test/testsim_lwt.exe test/testwidget.exe test/testwidget_lwt.exe)))) 8 | 9 | -------------------------------------------------------------------------------- /src/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: cc87e57084c66693ca0cc21138f857a7) 3 | version = "0.1" 4 | description = "A terminal based digital waveform viewer" 5 | requires = "hardcaml" 6 | archive(byte) = "HardCamlWaveTerm.cma" 7 | archive(byte, plugin) = "HardCamlWaveTerm.cma" 8 | archive(native) = "HardCamlWaveTerm.cmxa" 9 | archive(native, plugin) = "HardCamlWaveTerm.cmxs" 10 | exists_if = "HardCamlWaveTerm.cma" 11 | package "lterm" ( 12 | version = "0.1" 13 | description = "A terminal based digital waveform viewer" 14 | requires = "hardcaml hardcaml-waveterm lwt lambda-term" 15 | archive(byte) = "HardCamlWaveLTerm.cma" 16 | archive(byte, plugin) = "HardCamlWaveLTerm.cma" 17 | archive(native) = "HardCamlWaveLTerm.cmxa" 18 | archive(native, plugin) = "HardCamlWaveLTerm.cmxs" 19 | exists_if = "HardCamlWaveLTerm.cma" 20 | ) 21 | # OASIS_STOP 22 | 23 | -------------------------------------------------------------------------------- /src/api.ml.old: -------------------------------------------------------------------------------- 1 | module Make(B : HardCaml.Comb.S) = struct 2 | 3 | module Waveterm_waves = HardCamlWaveTerm.Wave.Make( HardCamlWaveTerm.Wave.Bits(B) ) 4 | module Waveterm_sim = HardCamlWaveTerm.Sim.Make(B)(Waveterm_waves) 5 | module Waveterm_ui = Ui.Make(B)(Waveterm_waves) 6 | 7 | end 8 | 9 | include Make(HardCaml.Bits.Comb.IntbitsList) 10 | 11 | -------------------------------------------------------------------------------- /src/gfx.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | module Style = struct 4 | type colour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White 5 | type t = 6 | { 7 | bold : bool; 8 | fg : colour; 9 | bg : colour; 10 | } 11 | let default = 12 | { 13 | bold = false; 14 | fg = White; 15 | bg = Black; 16 | } 17 | end 18 | 19 | type rect = 20 | { 21 | r : int; 22 | c : int; 23 | w : int; 24 | h : int; 25 | } 26 | 27 | type piece = 28 | (* lines *) 29 | TL | BR | BL | TR | V | H | T | Tu | C | 30 | (* full/half blocks *) 31 | F | TH | BH | LH | RH | 32 | (* quarter blocks *) 33 | QTL | QBR | QBL | QTR 34 | 35 | let bars = true (* kinda interesting *) 36 | 37 | let unicode_of_piece = function 38 | | TL -> 0x2518 39 | | BR -> 0x250c 40 | | BL -> 0x2510 41 | | TR -> 0x2514 42 | | V -> 0x2502 43 | | H -> 0x2500 44 | | T -> 0x252c 45 | | Tu -> 0x2534 46 | | C -> 0x253c 47 | | F -> if bars then 0x2551 else 0x2588 48 | | TH -> if bars then 0x2568 else 0x2580 49 | | BH -> if bars then 0x2565 else 0x2584 50 | | LH -> 0x258c 51 | | RH -> 0x2590 52 | | QTL -> 0x2598 53 | | QBR -> 0x2597 54 | | QBL -> 0x2596 55 | | QTR -> 0x259d 56 | 57 | module type Api = sig 58 | 59 | type ctx 60 | type style 61 | 62 | val get_bounds : ctx -> rect 63 | 64 | val get_style : Style.t -> style 65 | 66 | val clear : ctx -> unit 67 | 68 | val fill : 69 | ctx:ctx -> style:style -> bounds:rect -> 70 | char -> unit 71 | 72 | val draw_int : 73 | ctx:ctx -> style:style -> bounds:rect -> 74 | r:int -> c:int -> int -> unit 75 | 76 | val draw_piece : 77 | ctx:ctx -> style:style -> bounds:rect -> 78 | r:int -> c:int -> piece -> unit 79 | 80 | val draw_char : 81 | ctx:ctx -> style:style -> bounds:rect -> 82 | r:int -> c:int -> char -> unit 83 | 84 | val draw_string : 85 | ctx:ctx -> style:style -> bounds:rect -> 86 | r:int -> c:int -> string -> unit 87 | 88 | val draw_box : 89 | ctx:ctx -> style:style -> bounds:rect -> 90 | string -> unit 91 | 92 | val get : ctx:ctx -> bounds:rect -> r:int -> c:int -> int * Style.t 93 | 94 | val inv : ctx:ctx -> bounds:rect -> r:int -> c:int -> unit 95 | 96 | val bold : ctx:ctx -> bounds:rect -> r:int -> c:int -> unit 97 | 98 | end 99 | 100 | module type Brick = sig 101 | 102 | type ctx 103 | type style 104 | 105 | val get_bounds : ctx -> rect 106 | 107 | val get_style : Style.t -> style 108 | 109 | val draw_int : 110 | ctx:ctx -> style:style -> bounds:rect -> 111 | r:int -> c:int -> int -> unit 112 | 113 | val get : ctx:ctx -> bounds:rect -> r:int -> c:int -> int * Style.t 114 | 115 | end 116 | 117 | module Build(B : Brick) = struct 118 | 119 | include B 120 | 121 | let draw_char ~ctx ~style ~bounds ~r ~c ch = 122 | draw_int ~ctx ~style ~bounds ~r ~c (Char.to_int ch) 123 | 124 | let draw_piece ~ctx ~style ~bounds ~r ~c piece = 125 | draw_int ~ctx ~style ~bounds ~r ~c (unicode_of_piece piece) 126 | 127 | let fill ~ctx ~style ~bounds ch = 128 | for r=0 to bounds.h - 1 do 129 | for c=0 to bounds.w - 1 do 130 | draw_char ~ctx ~style ~bounds ~r ~c ch 131 | done; 132 | done 133 | 134 | let clear ctx = 135 | let bounds = get_bounds ctx in 136 | let style = get_style Style.default in 137 | for r=0 to bounds.h - 1 do 138 | for c=0 to bounds.w - 1 do 139 | draw_char ~ctx ~style ~bounds ~r ~c ' ' 140 | done 141 | done 142 | 143 | let draw_string ~ctx ~style ~bounds ~r ~c str = 144 | for i=0 to String.length str - 1 do 145 | draw_char ~ctx ~style ~bounds ~r ~c:(c+i) str.[i] 146 | done 147 | 148 | let draw_box ~ctx ~style ~bounds label = 149 | let w, h = bounds.w, bounds.h in 150 | assert (w>=2 && h>=2); (* min box size including borders *) 151 | draw_piece ~ctx ~style ~bounds ~r:0 ~c:0 BR; 152 | draw_piece ~ctx ~style ~bounds ~r:(h-1) ~c:0 TR; 153 | draw_piece ~ctx ~style ~bounds ~r:0 ~c:(w-1) BL; 154 | draw_piece ~ctx ~style ~bounds ~r:(h-1) ~c:(w-1) TL; 155 | for c=1 to (w-2) do draw_piece ~ctx ~style ~bounds ~r:0 ~c H done; 156 | for c=1 to (w-2) do draw_piece ~ctx ~style ~bounds ~r:(h-1) ~c H done; 157 | for r=1 to (h-2) do draw_piece ~ctx ~style ~bounds ~r ~c:0 V done; 158 | for r=1 to (h-2) do draw_piece ~ctx ~style ~bounds ~r ~c:(w-1) V done; 159 | draw_string ~ctx ~style ~bounds:{bounds with w=w-1} ~r:0 ~c:1 label 160 | 161 | let inv ~ctx ~bounds ~r ~c = 162 | try 163 | let x,s = get ~ctx ~bounds ~r ~c in 164 | let style = get_style Style.({s with fg=s.bg; bg=s.fg}) in 165 | draw_int ~ctx ~style ~bounds ~r ~c x 166 | with _ -> () 167 | 168 | let bold ~ctx ~bounds ~r ~c = 169 | try 170 | let x,s = get ~ctx ~bounds ~r ~c in 171 | let style = get_style Style.({s with bold=true}) in 172 | draw_int ~ctx ~style ~bounds ~r ~c x 173 | with _ -> () 174 | end 175 | 176 | module In_memory = struct 177 | 178 | type point = int * Style.t 179 | 180 | module Brick = struct 181 | 182 | type ctx = point array array 183 | type style = Style.t 184 | 185 | let rows ctx = Array.length ctx 186 | let cols ctx = try Array.length ctx.(0) with _ -> 0 187 | 188 | let get_bounds ctx = { r=0; c=0; h=rows ctx; w=cols ctx } 189 | 190 | let get_style s = s 191 | 192 | let draw_int ~ctx ~style ~bounds ~r ~c i = 193 | if r >= 0 && r < bounds.h && c >= 0 && c < bounds.w then begin 194 | ctx.(bounds.r + r).(bounds.c + c) <- i, style 195 | end 196 | 197 | let get ~ctx ~bounds ~r ~c = 198 | if r >= 0 && r < bounds.h && c >= 0 && c < bounds.w then begin 199 | ctx.(bounds.r + r).(bounds.c + c) 200 | end else 201 | raise (Invalid_argument "Gfx.get: out of bounds") 202 | 203 | end 204 | 205 | module Api = Build(Brick) 206 | 207 | let init ~rows ~cols = 208 | let ch = Char.to_int ' ' in 209 | Array.init rows (fun r -> Array.init cols (fun c -> ch, Style.default)) 210 | 211 | end 212 | 213 | -------------------------------------------------------------------------------- /src/gfx.mli: -------------------------------------------------------------------------------- 1 | (** Styling information *) 2 | module Style : sig 3 | (** colour *) 4 | type colour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White 5 | (** foreground/backgound colours and weight (bold) *) 6 | type t = 7 | { 8 | bold : bool; 9 | fg : colour; 10 | bg : colour; 11 | } 12 | (** white on black, normal weight *) 13 | val default : t 14 | end 15 | 16 | (** A rectangle (no really) *) 17 | type rect = 18 | { 19 | r : int; (** rows *) 20 | c : int; (** cols *) 21 | w : int; (** width *) 22 | h : int; (** height *) 23 | } 24 | 25 | type piece = 26 | (** corners, vert/horz bar, T shapes, cross *) 27 | TL | BR | BL | TR | V | H | T | Tu | C | 28 | (* full/half blocks *) 29 | F | TH | BH | LH | RH | 30 | (* quarter blocks *) 31 | QTL | QBR | QBL | QTR 32 | 33 | (** unicode value of piece *) 34 | val unicode_of_piece : piece -> int 35 | 36 | (** Main graphics drawing API. 37 | 38 | Most functions take a [bounds] parameter which is a rectangle 39 | to which drawing is clipped and also serves as an origin for 40 | any coordinates. *) 41 | module type Api = sig 42 | 43 | (** drawing context *) 44 | type ctx 45 | 46 | (** underlying style type *) 47 | type style 48 | 49 | (** get context size *) 50 | val get_bounds : ctx -> rect 51 | 52 | (** convert our style info to underlying style *) 53 | val get_style : Style.t -> style 54 | 55 | (** clear display *) 56 | val clear : ctx -> unit 57 | 58 | (** fill [bounds] with [char] given [style] *) 59 | val fill : 60 | ctx:ctx -> style:style -> bounds:rect -> 61 | char -> unit 62 | 63 | (** draw int (representing unicode value) *) 64 | val draw_int : 65 | ctx:ctx -> style:style -> bounds:rect -> 66 | r:int -> c:int -> int -> unit 67 | 68 | (** draw piece *) 69 | val draw_piece : 70 | ctx:ctx -> style:style -> bounds:rect -> 71 | r:int -> c:int -> piece -> unit 72 | 73 | (** draw char *) 74 | val draw_char : 75 | ctx:ctx -> style:style -> bounds:rect -> 76 | r:int -> c:int -> char -> unit 77 | 78 | (** draw string (nothing fancy - horizontal, no breaks) *) 79 | val draw_string : 80 | ctx:ctx -> style:style -> bounds:rect -> 81 | r:int -> c:int -> string -> unit 82 | 83 | (** draw box outline with label *) 84 | val draw_box : 85 | ctx:ctx -> style:style -> bounds:rect -> 86 | string -> unit 87 | 88 | (** get value and style at point *) 89 | val get : ctx:ctx -> bounds:rect -> r:int -> c:int -> int * Style.t 90 | 91 | (** invert fg and bg at point *) 92 | val inv : ctx:ctx -> bounds:rect -> r:int -> c:int -> unit 93 | 94 | (** set bold on point *) 95 | val bold : ctx:ctx -> bounds:rect -> r:int -> c:int -> unit 96 | 97 | end 98 | 99 | (** The basic functions needed to build the full API *) 100 | module type Brick = sig 101 | 102 | type ctx 103 | type style 104 | 105 | val get_bounds : ctx -> rect 106 | 107 | val get_style : Style.t -> style 108 | 109 | val draw_int : 110 | ctx:ctx -> style:style -> bounds:rect -> 111 | r:int -> c:int -> int -> unit 112 | 113 | val get : ctx:ctx -> bounds:rect -> r:int -> c:int -> int * Style.t 114 | 115 | end 116 | 117 | (** Construct the API from a Brick implementation *) 118 | module Build(B : Brick) : Api 119 | with type ctx = B.ctx 120 | 121 | (** In memory based API with no external requirements *) 122 | module In_memory : sig 123 | 124 | type point = int * Style.t 125 | 126 | module Api : Api 127 | with type ctx = point array array 128 | 129 | val init : rows:int -> cols:int -> Api.ctx 130 | 131 | end 132 | 133 | -------------------------------------------------------------------------------- /src/gfx_lterm.ml: -------------------------------------------------------------------------------- 1 | module Brick = struct 2 | 3 | open CamomileLibrary 4 | open Gfx 5 | 6 | type ctx = LTerm_draw.context 7 | type style = LTerm_style.t 8 | 9 | let get_bounds ctx = 10 | let size = LTerm_draw.size ctx in 11 | { r=0; c=0; h=size.LTerm_geom.rows; w=size.LTerm_geom.cols } 12 | 13 | let get_colour c = 14 | let open LTerm_style in 15 | let open Style in 16 | match c with 17 | | Black -> black | Red -> red | Green -> green | Yellow -> yellow 18 | | Blue -> blue | Magenta -> magenta | Cyan -> cyan | White -> white 19 | 20 | let of_colour c = 21 | let open LTerm_style in 22 | let open Style in 23 | if c = black then Black 24 | else if c = red then Red 25 | else if c = green then Green 26 | else if c = yellow then Yellow 27 | else if c = blue then Blue 28 | else if c = magenta then Magenta 29 | else if c = cyan then Cyan 30 | else if c = white then White 31 | else Black (* ??? *) 32 | 33 | let get_style style = 34 | { LTerm_style.none with 35 | LTerm_style.foreground = Some (get_colour style.Style.fg); 36 | LTerm_style.background = Some (get_colour style.Style.bg); 37 | LTerm_style.bold = Some style.Style.bold; } 38 | 39 | let clear ctx = LTerm_draw.clear ctx 40 | 41 | let draw_int ~ctx ~style ~bounds ~r ~c i = 42 | if r >=0 && r < bounds.h && c >= 0 && c < bounds.w then begin 43 | LTerm_draw.draw_char ctx ~style (bounds.r + r) (bounds.c + c) 44 | (UChar.of_int i) 45 | end 46 | 47 | let get ~ctx ~bounds ~r ~c = 48 | if r >=0 && r < bounds.h && c >= 0 && c < bounds.w then 49 | let point = LTerm_draw.point ctx (bounds.r + r) (bounds.c + c) in 50 | UChar.int_of point.LTerm_draw.char, 51 | Style.({ 52 | bold = point.LTerm_draw.bold; 53 | fg = of_colour point.LTerm_draw.foreground; 54 | bg = of_colour point.LTerm_draw.background; 55 | }) 56 | else 57 | raise (Invalid_argument "out of bounds") 58 | 59 | end 60 | 61 | module Api = Gfx.Build(Brick) 62 | 63 | -------------------------------------------------------------------------------- /src/gfx_lterm.mli: -------------------------------------------------------------------------------- 1 | (** Lambda-term based gfx API *) 2 | module Api : Gfx.Api 3 | with type ctx = LTerm_draw.context 4 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name "HardCamlWaveTerm") 5 | (public_name "hardcaml-waveterm") 6 | (libraries (lambda-term hardcaml astring)) 7 | (preprocess (pps (lwt_ppx))))) 8 | -------------------------------------------------------------------------------- /src/lTerm_waveterm_compat.ml: -------------------------------------------------------------------------------- 1 | module LTerm_scroll_impl = struct 2 | 3 | open CamomileLibrary 4 | open LTerm_geom 5 | 6 | class t = LTerm_widget.t 7 | 8 | let hbar = 0x2550 9 | let vbar = 0x2551 10 | 11 | let map_range range1 range2 offset1 = 12 | if range1 = 0 then 0 13 | else 14 | let map_range range1 range2 offset1 = 15 | max 0. (min range2 (range2 *. offset1 /. range1)) 16 | in 17 | let rnd x = int_of_float (x +. 0.5) in 18 | rnd @@ map_range 19 | (float_of_int range1) 20 | (float_of_int range2) 21 | (float_of_int offset1) 22 | 23 | class adjustment = object(self) 24 | 25 | (* callbacks *) 26 | val offset_change_callbacks = LTerm_widget_callbacks.create () 27 | method on_offset_change ?switch (f : int -> unit) = 28 | LTerm_widget_callbacks.register switch offset_change_callbacks f 29 | 30 | val mutable range = 0 31 | val mutable offset = 0 32 | 33 | method range = range 34 | method set_range ?(trigger_callback=true) r = 35 | range <- max 0 r; 36 | self#set_offset ~trigger_callback offset (* ensure offset is clipped to the new range *) 37 | 38 | method offset = offset 39 | method set_offset ?(trigger_callback=true) o = 40 | let o' = max 0 (min (range-1) o) in 41 | if offset <> o' then begin 42 | offset <- o'; 43 | if trigger_callback then 44 | LTerm_widget_callbacks.exec_callbacks offset_change_callbacks o' 45 | end 46 | 47 | end 48 | 49 | class scrollable_adjustment = object(self) 50 | inherit adjustment as adj 51 | 52 | val scrollbar_change_callbacks = LTerm_widget_callbacks.create () 53 | method on_scrollbar_change ?switch (f : unit -> unit) = 54 | LTerm_widget_callbacks.register switch scrollbar_change_callbacks f 55 | 56 | method set_offset ?(trigger_callback=true) o = 57 | adj#set_offset ~trigger_callback o; 58 | self#set_scroll_bar_offset (self#scroll_of_window self#offset) 59 | 60 | method set_range ?(trigger_callback=true) r = 61 | adj#set_range ~trigger_callback r; 62 | self#set_scroll_bar_offset (self#scroll_of_window self#offset) 63 | 64 | val mutable scroll_window_size = 0 65 | method private scroll_window_size = scroll_window_size 66 | method set_scroll_window_size s = scroll_window_size <- s 67 | 68 | val mutable scroll_bar_mode : [ `fixed of int | `dynamic of int ] = `fixed 5 69 | method set_scroll_bar_mode m = scroll_bar_mode <- m 70 | 71 | method private scroll_bar_size_fixed size = 72 | let wsize = self#scroll_window_size in 73 | if wsize <= size then max 1 (wsize-1) 74 | else max 1 size 75 | 76 | method private scroll_bar_size_dynamic view_size = 77 | if range <= 1 then 78 | self#scroll_window_size 79 | else if view_size <= 0 then 80 | max 1 (self#scroll_window_size / max 1 range) 81 | else 82 | let range = float_of_int range in 83 | let scroll_size = float_of_int @@ self#scroll_window_size in 84 | let view_size = float_of_int view_size in 85 | let doc_size = view_size +. range in 86 | int_of_float @@ scroll_size *. view_size /. doc_size 87 | 88 | val mutable min_scroll_bar_size : int option = None 89 | method private min_scroll_bar_size = 90 | match min_scroll_bar_size with None -> 1 | Some(x) -> x 91 | method set_min_scroll_bar_size min = min_scroll_bar_size <- Some(min) 92 | 93 | val mutable max_scroll_bar_size : int option = None 94 | method private max_scroll_bar_size = 95 | match max_scroll_bar_size with None -> self#scroll_window_size | Some(x) -> x 96 | method set_max_scroll_bar_size max = max_scroll_bar_size <- Some(max) 97 | 98 | val mutable scroll_bar_size = 0 99 | method private scroll_bar_size = 100 | let size = 101 | max self#min_scroll_bar_size @@ min self#max_scroll_bar_size @@ 102 | match scroll_bar_mode with 103 | | `fixed size -> self#scroll_bar_size_fixed size 104 | | `dynamic size -> self#scroll_bar_size_dynamic size 105 | in 106 | (if scroll_bar_size <> size then begin 107 | scroll_bar_size <- size; 108 | LTerm_widget_callbacks.exec_callbacks scrollbar_change_callbacks () 109 | end); 110 | size 111 | 112 | method private scroll_bar_steps = 113 | self#scroll_window_size - self#scroll_bar_size + 1 114 | 115 | val mutable scroll_bar_offset = 0 116 | method private set_scroll_bar_offset o = 117 | let offset = max 0 (min (self#scroll_bar_steps-1) o) in 118 | (if scroll_bar_offset <> offset then begin 119 | scroll_bar_offset <- offset; 120 | LTerm_widget_callbacks.exec_callbacks scrollbar_change_callbacks () 121 | end) 122 | 123 | method private window_of_scroll offset = 124 | map_range (self#scroll_bar_steps-1) (range-1) offset 125 | 126 | method private scroll_of_window offset = 127 | let offset = map_range (range-1) (self#scroll_bar_steps-1) offset in 128 | offset 129 | 130 | method incr = 131 | if range >= self#scroll_bar_steps then 132 | self#window_of_scroll (scroll_bar_offset+1) 133 | else 134 | (offset+1); 135 | 136 | method decr = 137 | if range >= self#scroll_bar_steps then 138 | self#window_of_scroll (scroll_bar_offset-1) 139 | else 140 | (offset-1); 141 | 142 | (* mouse click control *) 143 | 144 | (* scale whole scroll bar area into the number of steps. The scroll 145 | bar will not necessarily end up where clicked. Add a small dead_zone 146 | at far left and right *) 147 | method private mouse_scale_ratio scroll = 148 | let steps, size = self#scroll_bar_steps, self#scroll_bar_size in 149 | let wsize = self#scroll_window_size in 150 | let dead_zone = wsize / 5 in (* ~10% at each end *) 151 | map_range (wsize - dead_zone - 1) (steps - 1) (scroll - dead_zone/2) 152 | 153 | (* place the middle of the scroll bar at the cursor. Large scroll bars 154 | will reduce the clickable area by their size. *) 155 | method private mouse_scale_middle scroll = 156 | let size = self#scroll_bar_size in 157 | scroll - (size/2) 158 | 159 | method private mouse_scale_auto scroll = 160 | if self#scroll_bar_size > self#scroll_window_size/2 then 161 | self#mouse_scale_ratio scroll 162 | else 163 | self#mouse_scale_middle scroll 164 | 165 | val mutable mouse_mode : [ `middle | `ratio | `auto ] = `middle 166 | method set_mouse_mode m = mouse_mode <- m 167 | 168 | method private scroll_of_mouse scroll = 169 | match mouse_mode with 170 | | `middle -> self#mouse_scale_middle scroll 171 | | `ratio -> self#mouse_scale_ratio scroll 172 | | `auto -> self#mouse_scale_auto scroll 173 | 174 | method mouse_scroll scroll = 175 | self#window_of_scroll @@ self#scroll_of_mouse scroll 176 | 177 | val mutable page_size = -1 178 | val mutable document_size = -1 179 | 180 | method calculate_range page_size document_size = document_size-page_size+1 181 | 182 | method private update_page_and_document_sizes page doc = 183 | if page_size <> page || document_size <> doc then begin 184 | page_size <- page; 185 | document_size <- doc; 186 | let range = max 0 (self#calculate_range page_size document_size) in 187 | self#set_range range; 188 | self#set_mouse_mode `auto; 189 | self#set_scroll_bar_mode (`dynamic page_size); 190 | end 191 | 192 | method page_size = page_size 193 | method set_page_size s = self#update_page_and_document_sizes s document_size 194 | 195 | method document_size = document_size 196 | method set_document_size s = self#update_page_and_document_sizes page_size s 197 | 198 | method page_prev = self#offset - page_size 199 | method page_next = self#offset + page_size 200 | 201 | method get_render_params = 202 | scroll_bar_offset, 203 | self#scroll_bar_size, 204 | self#scroll_window_size 205 | 206 | end 207 | 208 | class virtual scrollbar 209 | rc default_event_handler 210 | (adj : #scrollable_adjustment) = object(self) 211 | inherit t rc 212 | 213 | method can_focus = true 214 | 215 | (* style *) 216 | val mutable focused_style = LTerm_style.none 217 | val mutable unfocused_style = LTerm_style.none 218 | val mutable bar_style : [ `filled | `outline ] = `outline 219 | val mutable show_track = false 220 | method update_resources = 221 | let rc = self#resource_class and resources = self#resources in 222 | focused_style <- LTerm_resources.get_style (rc ^ ".focused") resources; 223 | unfocused_style <- LTerm_resources.get_style (rc ^ ".unfocused") resources; 224 | bar_style <- 225 | (match LTerm_resources.get (rc ^ ".barstyle") resources with 226 | | "filled" -> `filled 227 | | "outline" | "" -> `outline 228 | | str -> Printf.ksprintf failwith "invalid scrollbar style"); 229 | show_track <- 230 | (match LTerm_resources.get_bool (rc ^ ".track") resources with 231 | | Some(x) -> x 232 | | None -> false) 233 | 234 | (* virtual methods needed to abstract over vert/horz scrollbars *) 235 | 236 | method virtual private mouse_offset : LTerm_mouse.t -> rect -> int 237 | method virtual private scroll_incr_key : LTerm_key.t 238 | method virtual private scroll_decr_key : LTerm_key.t 239 | 240 | (* event handling *) 241 | method mouse_event ev = 242 | let open LTerm_mouse in 243 | let alloc = self#allocation in 244 | match ev with 245 | | LTerm_event.Mouse m when m.button=Button1 && 246 | not m.control && not m.shift && not m.meta -> 247 | let scroll = self#mouse_offset m alloc in 248 | adj#set_offset @@ adj#mouse_scroll scroll; 249 | true 250 | | _ -> false 251 | 252 | method scroll_key_event ev = 253 | let open LTerm_key in 254 | match ev with 255 | | LTerm_event.Key k when k = self#scroll_decr_key -> adj#set_offset adj#decr; true 256 | | LTerm_event.Key k when k = self#scroll_incr_key -> adj#set_offset adj#incr; true 257 | | _ -> false 258 | 259 | (* drawing *) 260 | method private draw_bar ctx style rect = 261 | let open LTerm_draw in 262 | let { cols; rows } = size_of_rect rect in 263 | if cols=1 || rows=1 || bar_style=`filled then 264 | let x = 265 | CamomileLibrary.UChar.of_int @@ 266 | if bar_style=`filled then 0x2588 267 | else if cols=1 then vbar 268 | else hbar 269 | in 270 | for c=rect.col1 to rect.col2-1 do 271 | for r=rect.row1 to rect.row2-1 do 272 | draw_char ctx r c ~style x 273 | done 274 | done 275 | else 276 | draw_frame ctx rect ~style Light 277 | 278 | (* auto-draw *) 279 | initializer 280 | adj#on_scrollbar_change (fun () -> self#queue_draw) 281 | 282 | initializer 283 | if default_event_handler then 284 | self#on_event (fun ev -> self#mouse_event ev || self#scroll_key_event ev) 285 | 286 | end 287 | 288 | class vscrollbar 289 | ?(rc="scrollbar") 290 | ?(default_event_handler=true) 291 | ?(width=2) 292 | adj = object(self) 293 | inherit scrollbar rc default_event_handler adj as super 294 | 295 | method size_request = { rows=0; cols=width } 296 | 297 | method private mouse_offset m alloc = m.LTerm_mouse.row - alloc.row1 298 | val scroll_incr_key = LTerm_key.({ control = false; meta = false; shift = true; code=Down}) 299 | val scroll_decr_key = LTerm_key.({ control = false; meta = false; shift = true; code=Up}) 300 | method private scroll_incr_key = scroll_incr_key 301 | method private scroll_decr_key = scroll_decr_key 302 | 303 | method set_allocation r = 304 | super#set_allocation r; 305 | adj#set_scroll_window_size (r.row2 - r.row1) 306 | 307 | method draw ctx focused = 308 | let open LTerm_draw in 309 | let focus = (self :> t) = focused in 310 | let { cols; _ } = size ctx in 311 | 312 | let style = if focus then focused_style else unfocused_style in 313 | fill_style ctx style; 314 | 315 | let offset, scroll_bar_size, scroll_window_size = adj#get_render_params in 316 | 317 | let rect = 318 | { row1 = offset; col1 = 0; 319 | row2 = offset + scroll_bar_size; col2 = cols } 320 | in 321 | 322 | (if show_track then draw_vline ctx 0 (cols/2) scroll_window_size ~style Light); 323 | self#draw_bar ctx style rect 324 | 325 | end 326 | 327 | class hscrollbar 328 | ?(rc="scrollbar") 329 | ?(default_event_handler=true) 330 | ?(height=2) 331 | adj = object(self) 332 | inherit scrollbar rc default_event_handler adj as super 333 | 334 | method size_request = { rows=height; cols=0 } 335 | 336 | method private mouse_offset m alloc = m.LTerm_mouse.col - alloc.col1 337 | val scroll_incr_key = LTerm_key.({ control = false; meta = false; shift = true; code=Right}) 338 | val scroll_decr_key = LTerm_key.({ control = false; meta = false; shift = true; code=Left}) 339 | method private scroll_incr_key = scroll_incr_key 340 | method private scroll_decr_key = scroll_decr_key 341 | 342 | method set_allocation r = 343 | super#set_allocation r; 344 | adj#set_scroll_window_size (r.col2 - r.col1) 345 | 346 | method draw ctx focused = 347 | let open LTerm_draw in 348 | let focus = (self :> t) = focused in 349 | let { rows; _ } = size ctx in 350 | 351 | let style = if focus then focused_style else unfocused_style in 352 | fill_style ctx style; 353 | 354 | let offset, scroll_bar_size, scroll_window_size = adj#get_render_params in 355 | 356 | let rect = 357 | { row1 = 0; col1 = offset; 358 | row2 = rows; col2 = offset + scroll_bar_size } 359 | in 360 | 361 | (if show_track then draw_hline ctx (rows/2) 0 scroll_window_size ~style Light); 362 | self#draw_bar ctx style rect 363 | 364 | end 365 | 366 | class vslider rng = 367 | let adj = new scrollable_adjustment in 368 | object(self) 369 | inherit vscrollbar ~rc:"slider" ~default_event_handler:false ~width:1 adj 370 | initializer 371 | adj#set_mouse_mode `middle; 372 | adj#set_scroll_bar_mode (`fixed 1); 373 | adj#set_range (max 0 rng); 374 | self#on_event (fun ev -> 375 | let open LTerm_key in 376 | match ev with 377 | | LTerm_event.Key { control = false; meta = false; shift = true; code=Up} -> 378 | adj#set_offset (adj#offset-1); 379 | true 380 | | LTerm_event.Key { control = false; meta = false; shift = true; code=Down } -> 381 | adj#set_offset (adj#offset+1); 382 | true 383 | | _ -> self#mouse_event ev) 384 | method size_request = { rows=rng; cols=1 } 385 | method offset = adj#offset 386 | method set_offset = adj#set_offset 387 | method range = adj#range 388 | method set_range = adj#set_range 389 | method on_offset_change = adj#on_offset_change 390 | end 391 | 392 | class hslider rng = 393 | let adj = new scrollable_adjustment in 394 | object(self) 395 | inherit hscrollbar ~rc:"slider" ~default_event_handler:false ~height:1 adj 396 | initializer 397 | adj#set_mouse_mode `middle; 398 | adj#set_scroll_bar_mode (`fixed 1); 399 | adj#set_range (max 0 rng); 400 | self#on_event (fun ev -> 401 | let open LTerm_key in 402 | match ev with 403 | | LTerm_event.Key { control = false; meta = false; shift = true; code=Left } -> 404 | adj#set_offset (adj#offset-1); 405 | true 406 | | LTerm_event.Key { control = false; meta = false; shift = true; code=Right } -> 407 | adj#set_offset (adj#offset+1); 408 | true 409 | | _ -> self#mouse_event ev) 410 | method size_request = { rows=1; cols=rng } 411 | method offset = adj#offset 412 | method set_offset = adj#set_offset 413 | method range = adj#range 414 | method set_range = adj#set_range 415 | method on_offset_change = adj#on_offset_change 416 | end 417 | 418 | end 419 | 420 | (* +-----------------------------------------------------------------+ 421 | | Scrollbars | 422 | +-----------------------------------------------------------------+ *) 423 | 424 | class adjustment = LTerm_scroll_impl.adjustment 425 | 426 | (** Interface between an adjustment and a scrollbar widget. *) 427 | class type scrollable_adjustment = object 428 | inherit adjustment 429 | method incr : int 430 | method decr : int 431 | method mouse_scroll : int -> int 432 | method set_scroll_bar_mode : [ `fixed of int | `dynamic of int ] -> unit 433 | method set_mouse_mode : [ `middle | `ratio | `auto ] -> unit 434 | method set_min_scroll_bar_size : int -> unit 435 | method set_max_scroll_bar_size : int -> unit 436 | method on_scrollbar_change : ?switch:LTerm_widget_callbacks.switch -> 437 | (unit -> unit) -> unit 438 | end 439 | 440 | class type scrollable_document = object 441 | method page_size : int 442 | method set_page_size : int -> unit 443 | method document_size : int 444 | method set_document_size : int -> unit 445 | method page_next : int 446 | method page_prev : int 447 | method calculate_range : int -> int -> int 448 | end 449 | 450 | class type scrollable_private = object 451 | method set_scroll_window_size : int -> unit 452 | method get_render_params : int * int * int 453 | end 454 | 455 | class type default_scroll_events = object 456 | method mouse_event : LTerm_event.t -> bool 457 | method scroll_key_event : LTerm_event.t -> bool 458 | end 459 | 460 | class scrollable = LTerm_scroll_impl.scrollable_adjustment 461 | 462 | class vscrollbar = LTerm_scroll_impl.vscrollbar 463 | 464 | class hscrollbar = LTerm_scroll_impl.hscrollbar 465 | 466 | class vslider = LTerm_scroll_impl.vslider 467 | 468 | class hslider = LTerm_scroll_impl.hslider 469 | 470 | module Button = struct 471 | 472 | open LTerm_geom 473 | open LTerm_key 474 | open LTerm_mouse 475 | 476 | class button ?(brackets=("< "," >")) initial_label = 477 | let bl, br = brackets in 478 | let brackets_size = String.length bl + String.length br in 479 | 480 | object(self) 481 | inherit LTerm_widget.t "button" as super 482 | 483 | method can_focus = true 484 | 485 | val click_callbacks = LTerm_widget_callbacks.create () 486 | 487 | method on_click ?switch f = 488 | LTerm_widget_callbacks.register switch click_callbacks f 489 | 490 | val mutable size_request = { rows = 1; cols = brackets_size + Zed_utf8.length initial_label } 491 | method size_request = size_request 492 | 493 | val mutable label = initial_label 494 | 495 | method label = label 496 | 497 | method set_label text = 498 | label <- text; 499 | size_request <- { rows = 1; cols = brackets_size + Zed_utf8.length text }; 500 | self#queue_draw 501 | 502 | initializer 503 | self#on_event 504 | (function 505 | | LTerm_event.Key { control = false; meta = false; shift = false; code = Enter } -> 506 | LTerm_widget_callbacks.exec_callbacks click_callbacks (); 507 | true 508 | | LTerm_event.Mouse m when m.button = Button1 -> 509 | LTerm_widget_callbacks.exec_callbacks click_callbacks (); 510 | true 511 | | _ -> 512 | false) 513 | 514 | val mutable focused_style = LTerm_style.none 515 | val mutable unfocused_style = LTerm_style.none 516 | method update_resources = 517 | let rc = self#resource_class and resources = self#resources in 518 | focused_style <- LTerm_resources.get_style (rc ^ ".focused") resources; 519 | unfocused_style <- LTerm_resources.get_style (rc ^ ".unfocused") resources 520 | 521 | method private apply_style ctx focused = 522 | let style = 523 | if focused = (self :> LTerm_widget.t) 524 | then focused_style 525 | else unfocused_style 526 | in 527 | LTerm_draw.fill_style ctx style 528 | 529 | method draw ctx focused = 530 | let { rows; cols } = LTerm_draw.size ctx in 531 | let len = Zed_utf8.length label in 532 | self#apply_style ctx focused; 533 | LTerm_draw.draw_string ctx (rows / 2) ((cols - len - brackets_size) / 2) 534 | (Printf.sprintf "%s%s%s" bl label br) 535 | end 536 | 537 | end 538 | 539 | module Frame = struct 540 | 541 | open LTerm_geom 542 | open LTerm_key 543 | open LTerm_mouse 544 | 545 | 546 | let draw_frame_labelled ctx rect ?style ?(alignment=H_align_left) label connection = 547 | let open LTerm_draw in 548 | let sub_opt ctx rect = try Some(sub ctx rect) with Out_of_bounds -> None in 549 | draw_frame ctx rect ?style connection; 550 | let rect = { row1 = rect.row1; row2 = rect.row1+1; col1 = rect.col1+1; col2 = rect.col2-1 } in 551 | match sub_opt ctx rect with 552 | | Some(ctx) -> draw_string_aligned ctx 0 alignment label 553 | | None -> () 554 | 555 | class frame = object(self) 556 | inherit LTerm_widget.t "frame" as super 557 | 558 | val mutable child = None 559 | method children = 560 | match child with 561 | | Some widget -> [widget] 562 | | None -> [] 563 | 564 | val mutable size_request = { rows = 2; cols = 2 } 565 | method size_request = size_request 566 | 567 | val mutable style = LTerm_style.none 568 | val mutable connection = LTerm_draw.Light 569 | method update_resources = 570 | let rc = self#resource_class and resources = self#resources in 571 | style <- LTerm_resources.get_style rc resources; 572 | connection <- LTerm_resources.get_connection (rc ^ ".connection") resources 573 | 574 | method private compute_size_request = 575 | match child with 576 | | Some widget -> 577 | let size = widget#size_request in 578 | size_request <- { rows = size.rows + 2; cols = size.cols + 2 } 579 | | None -> 580 | size_request <- { rows = 2; cols = 2 } 581 | 582 | method private compute_allocation = 583 | match child with 584 | | Some widget -> 585 | let rect = self#allocation in 586 | let row1 = min rect.row2 (rect.row1 + 1) and col1 = min rect.col2 (rect.col1 + 1) in 587 | widget#set_allocation { 588 | row1 = row1; 589 | col1 = col1; 590 | row2 = max row1 (rect.row2 - 1); 591 | col2 = max col1 (rect.col2 - 1); 592 | } 593 | | None -> 594 | () 595 | 596 | method set_allocation rect = 597 | super#set_allocation rect; 598 | self#compute_allocation 599 | 600 | method set : 'a. (#LTerm_widget.t as 'a) -> unit = fun widget -> 601 | child <- Some(widget :> LTerm_widget.t); 602 | widget#set_parent (Some (self :> LTerm_widget.t)); 603 | self#compute_size_request; 604 | self#compute_allocation; 605 | self#queue_draw 606 | 607 | method empty = 608 | match child with 609 | | Some widget -> 610 | widget#set_parent None; 611 | child <- None; 612 | self#compute_size_request; 613 | self#queue_draw 614 | | None -> 615 | () 616 | val mutable label = "" 617 | val mutable align = H_align_left 618 | method set_label ?(alignment=H_align_left) l = 619 | label <- l; 620 | align <- alignment 621 | 622 | method draw ctx focused = 623 | let size = LTerm_draw.size ctx in 624 | LTerm_draw.fill_style ctx style; 625 | if size.rows >= 1 && size.cols >= 1 then begin 626 | let rect = 627 | { row1 = 0; 628 | col1 = 0; 629 | row2 = size.rows; 630 | col2 = size.cols } 631 | in 632 | (if label = "" then LTerm_draw.draw_frame ctx rect connection 633 | else draw_frame_labelled ctx rect ~alignment:align label connection); 634 | if size.rows > 2 && size.cols > 2 then 635 | match child with 636 | | Some widget -> 637 | widget#draw 638 | (LTerm_draw.sub ctx { row1 = 1; 639 | col1 = 1; 640 | row2 = size.rows - 1; 641 | col2 = size.cols - 1 }) 642 | focused 643 | | None -> 644 | () 645 | end 646 | end 647 | 648 | end 649 | 650 | module Spacing = struct 651 | 652 | open LTerm_geom 653 | 654 | class spacing ?(rows=0) ?(cols=0) () = object 655 | inherit LTerm_widget.t "glue" 656 | val size_request = { rows; cols } 657 | method size_request = size_request 658 | end 659 | 660 | end 661 | -------------------------------------------------------------------------------- /src/render.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | module Styles = struct 4 | type t = 5 | { 6 | border : Gfx.Style.t option; 7 | signals : Gfx.Style.t; 8 | values : Gfx.Style.t; 9 | waves : Gfx.Style.t; 10 | status : Gfx.Style.t; 11 | } 12 | let default d = 13 | { border = Some(d); signals = d; values = d; waves = d; status = d } 14 | let white_on_black = default Gfx.Style.({ default with fg=White; bg=Black }) 15 | let black_on_white = default Gfx.Style.({ default with fg=Black; bg=White }) 16 | let colour s = 17 | { s with 18 | signals = Gfx.Style.({ s.signals with fg = Blue }); 19 | values = Gfx.Style.({ s.values with fg = Red }); 20 | waves = Gfx.Style.({ s.waves with fg = Green }); 21 | status = Gfx.Style.({ s.waves with fg = Magenta }); 22 | } 23 | let colour_on_black = colour white_on_black 24 | let colour_on_white = colour black_on_white 25 | end 26 | 27 | module Bounds = struct 28 | 29 | (* XXX Some stuff would be much simplified if the rects excluded the border 30 | and we just adjusted for it here. If the border is drawn it is on 31 | the outside of the rendering window *) 32 | 33 | type t = 34 | { 35 | signals : Gfx.rect; 36 | values : Gfx.rect; 37 | waves : Gfx.rect; 38 | status : Gfx.rect; 39 | } 40 | 41 | let expand_for_border x = 42 | let open Gfx in 43 | if x.w<>0 && x.h <> 0 then Gfx.({ r=x.r-1; c=x.c-1; w=x.w+2; h=x.h+2 }) 44 | else x 45 | 46 | let shrink_for_border x = 47 | let open Gfx in 48 | if x.w<>0 && x.h<>0 then Gfx.({ r=x.r+1; c=x.c+1; w=max 0 (x.w-2); h=max 0 (x.h-2) }) 49 | else x 50 | 51 | let fit_to_window 52 | ?(signals=true) ?(values=true) ?(waves=true) ?(status=false) 53 | ?(border=true) bounds = 54 | let open Gfx in 55 | let rows, cols = bounds.h, bounds.w in 56 | let minb = if border then 3 else 1 in 57 | let iw6 = max minb (min 20 (cols / 6)) in (* approx 1/6 of width, >minb and < 20 *) 58 | let iw4 = max minb (min 20 (cols / 4)) in (* approx 1/4 of width, >minb and < 20 *) 59 | let z = { r=0; c=0; w=0; h=rows-(if status then 3 else 0) } in 60 | let get_bounds w0 w1 w2 = 61 | if w2 <= 0 && waves then failwith "windows wont fit (sorry, should be more graceful!)" 62 | else 63 | let border x = 64 | if border && x.w <> 0 && x.h <> 0 then shrink_for_border x 65 | else x 66 | in 67 | { 68 | signals = border { z with w=w0 }; 69 | values = border { z with c=w0; w=w1 }; 70 | waves = border { z with c=w0+w1; w=w2 }; 71 | status = if status then border { r=bounds.h-3; c=0; h=3; w=bounds.w } else z; 72 | } 73 | in 74 | match signals, values, waves with 75 | (* all *) 76 | | true, true, true -> get_bounds iw6 iw6 (cols - iw6 - iw6) 77 | (* 2 *) 78 | | true, true, false -> get_bounds (cols/2) ((cols+1)/2) 0 79 | | true, false, true -> get_bounds iw4 0 (cols-iw4) 80 | | false, true, true -> get_bounds 0 iw4 (cols-iw4) 81 | (* 1 *) 82 | | true, false, false -> get_bounds cols 0 0 83 | | false, true, false -> get_bounds 0 cols 0 84 | | false, false, true -> get_bounds 0 0 cols 85 | (* 0 *) 86 | | false, false, false -> get_bounds 0 0 0 87 | 88 | 89 | end 90 | 91 | module Make(G : Gfx.Api) (W : Wave.W) = struct 92 | 93 | open G 94 | open W 95 | open Wave 96 | 97 | let get_wave_width (w,d) = 98 | if w < 0 then 99 | (* subcycle rendering *) 100 | match d with 101 | | Clock _ -> w, 1 102 | | Binary _ 103 | | Data _ -> w, 1 104 | else 105 | match d with 106 | | Clock _ -> w, (w+1)*2 107 | | Data _ 108 | | Binary _ -> (w*2)+1, (w+1)*2 109 | 110 | let get_wave_height = function 111 | | 0,Clock _ -> 0,2 112 | | 0,Data _ -> 0,2 113 | | 0,Binary _ -> 0,2 114 | | 1,Clock _ -> 0,2 115 | | 1,Data _ -> 1,3 116 | | 1,Binary _ -> 0,2 117 | | h,Clock _ -> h-1,h+1 118 | | h,Data _ -> h-1,h+1 119 | | h,Binary _ -> h-1,h+1 120 | 121 | let get_max_signal_width state = 122 | Array.fold_left 123 | (fun m s -> max m (String.length (get_name s))) 124 | 0 state.waves 125 | 126 | let get_max_value_width state = 127 | let fold f a d = 128 | let len = W.length d in 129 | let rec g a i = if i=len then a else g (f a (W.get d i)) (i+1) in 130 | g a 0 131 | in 132 | Array.fold_left 133 | (fun m w -> 134 | try 135 | let data = W.get_data w in 136 | let to_str = W.get_to_str w in 137 | let max m s = max m (String.length (to_str s)) in 138 | fold max m data 139 | with _ -> m) 140 | 0 state.waves 141 | 142 | let get_max_cycles state = 143 | Array.fold_left 144 | (fun m d -> 145 | max m (try W.length (W.get_data d) with _ -> 0)) 146 | 0 state.waves 147 | 148 | let get_max_signals state = Array.length state.waves 149 | 150 | let get_w_scale w = if w < -1 then - w else 1 151 | 152 | let get_max_wave_width state = 153 | let cycles = get_max_cycles state in 154 | let w, waw = get_wave_width (state.cfg.wave_width, Clock "") in 155 | let w_scale = get_w_scale w in 156 | waw * ((cycles + w_scale - 1) / w_scale) 157 | 158 | let get_max_wave_height state start_signal = 159 | let rec f acc i = 160 | if i < Array.length state.waves then 161 | let _, wah = get_wave_height (state.cfg.wave_height, state.waves.(i)) in 162 | f (acc + wah) (i+1) 163 | else 164 | acc 165 | in 166 | f 0 start_signal 167 | 168 | let get_max_bounds state = 169 | let open Gfx in 170 | let swidth = get_max_signal_width state in 171 | let vwidth = get_max_value_width state in 172 | let wwidth = get_max_wave_width state in 173 | let wheight = get_max_wave_height state state.cfg.start_signal in 174 | let z = { r=0; c=0; h=wheight; w=0 } in 175 | Bounds.({ 176 | signals = {z with w = swidth}; 177 | values = {z with w = vwidth}; 178 | waves = {z with w = wwidth}; 179 | status = z; 180 | }) 181 | 182 | let draw_clock_cycle ~ctx ~style ~bounds ~w ~h ~c = 183 | let open Gfx in 184 | if w < 0 then begin 185 | for c=c to c+1 do draw_piece ~ctx ~style ~bounds ~r:0 ~c:c BH; done; 186 | for r=1 to h do 187 | for c=c to c+1 do draw_piece ~ctx ~style ~bounds ~r:r ~c:c F; done 188 | done; 189 | for c=c to c+1 do draw_piece ~ctx ~style ~bounds ~r:(h+1) ~c:c TH; done; 190 | end else begin 191 | draw_piece ~ctx ~style ~bounds ~r:0 ~c:c BR; 192 | for i=0 to w-1 do draw_piece ~ctx ~style ~bounds ~r:0 ~c:(c+1+i) H done; 193 | draw_piece ~ctx ~style ~bounds ~r:0 ~c:(c+w+1) BL; 194 | for i=0 to h-1 do draw_piece ~ctx ~style ~bounds ~r:(0+i+1) ~c:(c+w+1) V done; 195 | draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c:(c+w+1) TR; 196 | for i=0 to w-1 do draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c:(c+w+2+i) H done; 197 | draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c:(c+w+w+2) TL; 198 | for i=0 to h-1 do draw_piece ~ctx ~style ~bounds ~r:(0+i+1) ~c:(c+w+w+2) V done 199 | end 200 | 201 | let draw_clock_cycles ~ctx ~style ~bounds ~w ~waw ~h ~cnt = 202 | for i=0 to cnt - 1 do 203 | draw_clock_cycle ~ctx ~style ~bounds ~w ~h ~c:(i*waw) 204 | done 205 | 206 | let wget data i = 207 | try W.get data i 208 | with _ -> W.get data (W.length data - 1) 209 | 210 | let get_fuzzy_data data i w_scale = 211 | let rec f i w_scale prev = 212 | if w_scale = 0 then Some prev 213 | else 214 | let d = wget data i in 215 | if W.compare d prev then f (i+1) (w_scale-1) prev 216 | else None 217 | in 218 | let d = wget data i in (* if we get 1 element, then we succeed *) 219 | try f (i+1) (w_scale-1) d with _ -> Some(d) 220 | 221 | let get_data_index off i w_scale = 222 | if w_scale < -1 then 223 | let w_scale = get_w_scale w_scale in 224 | (w_scale * i) + off 225 | else 226 | off + i 227 | 228 | let get_data data off i w_scale = 229 | if w_scale < -1 then 230 | let w_scale = get_w_scale w_scale in 231 | get_fuzzy_data data ((w_scale * i) + off) w_scale 232 | else 233 | Some (wget data (off + i)) 234 | 235 | let draw_binary_data ~ctx ~style ~bounds ~w ~h ~data ~off = 236 | let open Gfx in 237 | let w_scale, w = w, max 0 w in 238 | let rec f prev c i = 239 | if (c >= bounds.w) || (get_data_index off i w_scale >= W.length data) then () 240 | else 241 | let cur = get_data data off i w_scale in 242 | let low() = 243 | for i=0 to w do draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c:(c+i) H done 244 | in 245 | let low_high() = 246 | draw_piece ~ctx ~style ~bounds ~r:0 ~c BR; 247 | for i=0+1 to 0+h+1 do draw_piece ~ctx ~style ~bounds ~r:i ~c V done; 248 | draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c TL; 249 | for i=1 to w do draw_piece ~ctx ~style ~bounds ~r:0 ~c:(c+i) H done 250 | in 251 | let high_low() = 252 | draw_piece ~ctx ~style ~bounds ~r:0 ~c BL; 253 | for i=0+1 to 0+h+1 do draw_piece ~ctx ~style ~bounds ~r:i ~c V done; 254 | draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c TR; 255 | for i=1 to w do draw_piece ~ctx ~style ~bounds ~r:(0+h+1) ~c:(c+i) H done 256 | in 257 | let high () = 258 | for i=0 to w do draw_piece ~ctx ~style ~bounds ~r:0 ~c:(c+i) H done 259 | in 260 | let fuzz () = 261 | for c=c to c+w do draw_piece ~ctx ~style ~bounds ~r:0 ~c BH done; 262 | for c=c to c+w do 263 | for r=1 to h do draw_piece ~ctx ~style ~bounds ~r:r ~c F done 264 | done; 265 | for c=c to c+w do draw_piece ~ctx ~style ~bounds ~r:(h+1) ~c TH done 266 | in 267 | let fuzzy p = p=None in 268 | let zero = function Some(p) -> W.compare p W.zero | _ -> false in 269 | let one = function Some(p) -> W.compare p W.one | _ -> false in 270 | if fuzzy cur then fuzz () 271 | else if fuzzy prev && zero cur then low () 272 | else if fuzzy prev && one cur then high () 273 | else if zero prev && zero cur then low () 274 | else if one prev && zero cur then high_low () 275 | else if zero prev && one cur then low_high () 276 | else if one prev && one cur then high () 277 | else begin 278 | failwith "not binary data" 279 | end; 280 | f cur (c+w+1) (i+1) 281 | in 282 | try f None 0 0 283 | with _ -> () 284 | 285 | let draw_data ~ctx ~style ~bounds ~to_str ~w ~h ~data ~off = 286 | let w_scale, w = w, max 0 w in 287 | let draw_text r c cnt data = 288 | match data with 289 | | None -> () 290 | | Some(data) -> 291 | let str = to_str data in 292 | let putc i ch = draw_char ~ctx ~style ~bounds ~r ~c:(c+i) ch in 293 | let str_len = String.length str in 294 | if str_len <= cnt then 295 | for i=0 to str_len-1 do 296 | putc i str.[i] 297 | done 298 | else 299 | for i=0 to cnt-1 do 300 | putc i (if i=(cnt-1) then '.' else str.[i]) 301 | done 302 | in 303 | let rec f prev prev_cnt c i = 304 | let open Gfx in 305 | let r = 0 in 306 | if (c >= bounds.w) || (get_data_index off i w_scale >= W.length data) then 307 | (if h>0 then draw_text (r+1+((h-1)/2)) (c-prev_cnt) prev_cnt prev) 308 | else 309 | let cur = get_data data off i w_scale in 310 | let fuzzy p = p=None in 311 | let same a b = 312 | match a,b with 313 | | Some(a), Some(b) when W.compare a b -> true 314 | | _ -> false 315 | in 316 | let transn () = 317 | draw_piece ~ctx ~style ~bounds ~r ~c T; 318 | for r=r+1 to r+h do draw_piece ~ctx ~style ~bounds ~r ~c V done; 319 | draw_piece ~ctx ~style ~bounds ~r:(r+h+1) ~c Tu; 320 | for c=c+1 to c+w do 321 | draw_piece ~ctx ~style ~bounds ~r ~c H; 322 | draw_piece ~ctx ~style ~bounds ~r:(r+h+1) ~c H; 323 | done; 324 | in 325 | let extend () = 326 | for c=c to c+w do 327 | draw_piece ~ctx ~style ~bounds ~r ~c H; 328 | draw_piece ~ctx ~style ~bounds ~r:(r+h+1) ~c H; 329 | done; 330 | in 331 | let fuzz () = 332 | for c=c to c+w do draw_piece ~ctx ~style ~bounds ~r:0 ~c BH done; 333 | for c=c to c+w do 334 | for r=1 to h do draw_piece ~ctx ~style ~bounds ~r:r ~c F done 335 | done; 336 | for c=c to c+w do draw_piece ~ctx ~style ~bounds ~r:(h+1) ~c TH done; 337 | in 338 | let run fn txt ext = 339 | fn (); 340 | (if txt && h>0 then draw_text (r+1+((h-1)/2)) (c-prev_cnt) prev_cnt prev); 341 | f cur (if ext then prev_cnt+w+1 else w) (c+w+1) (i+1) 342 | in 343 | if fuzzy cur && not (fuzzy prev) then run fuzz true false 344 | else if fuzzy cur && fuzzy prev then run fuzz false false 345 | else if fuzzy prev then run extend false false 346 | else if same prev cur then run extend false true 347 | else run transn true false 348 | in 349 | (*try f None (-1) 0 0 350 | with _ -> ()*) 351 | f None (-1) 0 0 352 | 353 | let rec draw_iter i bounds state f = 354 | let open Gfx in 355 | if i < Array.length state.waves && bounds.h > 0 then begin 356 | let _, wah = get_wave_height (state.cfg.wave_height, state.waves.(i)) in 357 | f i bounds state.waves.(i); 358 | draw_iter (i+1) { bounds with r = bounds.r + wah; h = bounds.h - wah } state f 359 | end 360 | 361 | let draw_border ~border ~ctx ~bounds label = 362 | let open Gfx in 363 | let style = get_style border in 364 | G.draw_box ~ctx ~style ~bounds label 365 | 366 | type 'a draw_item = ?style:Gfx.Style.t -> ctx:G.ctx -> bounds:Gfx.rect -> W.waves -> 'a 367 | 368 | let with_border 369 | : draw:'a draw_item -> label:string -> ?border:Gfx.Style.t -> 'a draw_item 370 | = fun 371 | ~(draw:'a draw_item) ~label ?border 372 | ?(style=Gfx.Style.default) ~ctx ~bounds state -> 373 | let r = draw ~style ~ctx ~bounds state in 374 | match border with 375 | | Some(border) when bounds.Gfx.w>0 && bounds.Gfx.h>0 -> 376 | G.draw_box ~ctx ~style:(get_style border) ~bounds:(Bounds.expand_for_border bounds) label; 377 | r 378 | | _ -> 379 | r 380 | 381 | let draw_cursor ~ctx ~bounds ~state = 382 | let open Gfx in 383 | let w, waw = get_wave_width (state.cfg.wave_width, Clock "") in 384 | let w_scale = get_w_scale w in 385 | let cycle = state.cfg.wave_cursor - state.cfg.start_cycle in 386 | let c = (cycle * waw) / w_scale in 387 | for r=0 to bounds.h-1 do (* assume clipped when drawn *) 388 | inv ~ctx ~bounds ~r ~c 389 | done 390 | 391 | let draw_wave ?(style=Gfx.Style.default) ~ctx ~bounds state = 392 | let open Gfx in 393 | let style = get_style style in 394 | (*let max_cycles = get_max_cycles state in*) 395 | fill ~ctx ~bounds ~style ' '; 396 | draw_iter state.cfg.start_signal bounds state 397 | (fun _ bounds wave -> 398 | let wh, wah = get_wave_height (state.cfg.wave_height, wave) in 399 | let ww, waw = get_wave_width (state.cfg.wave_width, wave) in 400 | let cnt = (bounds.w + waw - 1) / waw in 401 | let off = state.cfg.start_cycle in 402 | (*let cnt = max 0 ((min (off+cnt) max_cycles) - off) in*) 403 | match wave with 404 | | Clock(_) -> 405 | draw_clock_cycles ~ctx ~style ~bounds ~w:ww ~waw ~h:wh ~cnt 406 | | Binary(_, data) -> 407 | let off = min (W.length data - 1) off in 408 | draw_binary_data ~ctx ~style ~bounds ~w:ww ~h:wh ~data ~off 409 | | Data(_, data, _) -> 410 | let off = min (W.length data - 1) off in 411 | draw_data ~ctx ~style ~bounds ~to_str:(W.get_to_str wave) ~w:ww ~h:wh ~data ~off); 412 | draw_cursor ~ctx ~bounds ~state 413 | 414 | let draw_highlight ~ctx ~bounds ~r b = 415 | if b then begin 416 | for c=0 to bounds.Gfx.w - 1 do 417 | inv ~ctx ~bounds ~r ~c 418 | done 419 | end 420 | 421 | let ssub s a b = String.Sub.to_string @@ String.sub s ~start:a ~stop:(a+b) 422 | 423 | let draw_scroll_string ~ctx ~style ~bounds ~r ~c str = 424 | let len = String.length str in 425 | let w = bounds.Gfx.w in 426 | if len <= w then draw_string ~ctx ~style ~bounds ~r ~c:0 str 427 | else 428 | let c = min c (len-w) in 429 | let str = try ssub str c w with _ -> "" in 430 | draw_string ~ctx ~style ~bounds ~r ~c:0 str 431 | 432 | let draw_scroll_string_right ~ctx ~style ~bounds ~r ~c str = 433 | let len = String.length str in 434 | let w = bounds.Gfx.w in 435 | let sub_right s o l = try ssub s (len - l - o) l with _ -> "" in 436 | let draw_string_right ~ctx ~style ~bounds ~r str = 437 | let c = w - String.length str in 438 | draw_string ~ctx ~style ~bounds ~r ~c str 439 | in 440 | if len <= w then draw_string_right ~ctx ~style ~bounds ~r str 441 | else 442 | let c = min c (len-w) in 443 | draw_string_right ~ctx ~style ~bounds ~r (sub_right str c w) 444 | 445 | let draw_signals ?(style=Gfx.Style.default) ~ctx ~bounds state = 446 | let open Gfx in 447 | let style = get_style style in 448 | fill ~ctx ~bounds ~style ' '; 449 | draw_iter state.cfg.start_signal bounds state 450 | (fun i bounds wave -> 451 | let _, wah = get_wave_height (state.cfg.wave_height, wave) in 452 | let r = (wah-1) / 2 in 453 | draw_scroll_string ~ctx ~style ~bounds ~r ~c:state.cfg.signal_scroll (W.get_name wave); 454 | draw_highlight ~ctx ~bounds ~r (i = state.cfg.signal_cursor)) 455 | 456 | let draw_values ?(style=Gfx.Style.default) ~ctx ~bounds state = 457 | let open Gfx in 458 | let style = get_style style in 459 | fill ~ctx ~bounds ~style ' '; 460 | let off = if state.cfg.wave_cursor < 0 then state.cfg.start_cycle else state.cfg.wave_cursor in 461 | let max_string_length = ref 0 in 462 | draw_iter state.cfg.start_signal bounds state 463 | (fun i bounds wave -> 464 | let _, wah = get_wave_height (state.cfg.wave_height, wave) in 465 | let r = (wah-1) / 2 in 466 | begin match wave with 467 | | Clock _ -> () 468 | | Binary(_, d) -> 469 | let d = try W.get d off with _ -> W.get d (W.length d - 1) in 470 | let str = W.to_bstr d in 471 | max_string_length := max !max_string_length (String.length str); 472 | draw_scroll_string_right ~ctx ~style ~bounds ~r ~c:state.cfg.value_scroll str 473 | | Data(_, d, _) -> 474 | let d = try W.get d off with _ -> W.get d (W.length d - 1) in 475 | let to_str = W.get_to_str wave in 476 | let str = to_str d in 477 | max_string_length := max !max_string_length (String.length str); 478 | draw_scroll_string_right ~ctx ~style ~bounds ~r ~c:state.cfg.value_scroll str 479 | end; 480 | draw_highlight ~ctx ~bounds ~r (i = state.cfg.signal_cursor)); 481 | !max_string_length 482 | 483 | let draw_status ?(style=Gfx.Style.default) ~ctx ~bounds state = 484 | let open Gfx in 485 | let style = get_style style in 486 | fill ~ctx ~bounds ~style ' '; 487 | draw_string ~ctx ~style ~bounds ~r:0 ~c:0 488 | (Printf.sprintf 489 | "cycle=%i cursor=%i w=%i h=%i sc=%i vs=%i" 490 | state.cfg.start_cycle state.cfg.wave_cursor state.cfg.wave_width state.cfg.wave_height 491 | state.cfg.signal_scroll state.cfg.value_scroll) 492 | 493 | let draw_ui 494 | ?(style=Styles.default Gfx.Style.default) ?bounds 495 | ~ctx state = 496 | let open Styles in 497 | let open Bounds in 498 | 499 | let bounds = 500 | match bounds with 501 | | None -> fit_to_window (get_bounds ctx) 502 | | Some(b) -> b 503 | in 504 | 505 | with_border ~draw:draw_signals ~label:"Signals" 506 | ~style:style.signals ?border:style.border ~ctx ~bounds:bounds.signals state; 507 | ignore @@ with_border ~draw:draw_values ~label:"Values" 508 | ~style:style.values ?border:style.border ~ctx ~bounds:bounds.values state; 509 | with_border ~draw:draw_wave ~label:"Waves" 510 | ~style:style.waves ?border:style.border ~ctx ~bounds:bounds.waves state; 511 | with_border ~draw:draw_status ~label:"Status" 512 | ~style:style.status ?border:style.border ~ctx ~bounds:bounds.status state 513 | 514 | type pick = 515 | | Wave of int * int 516 | | Value of int 517 | | Signal of int 518 | | Status 519 | | No_pick 520 | 521 | let pick ~bounds ~r ~c state = 522 | let open Gfx in 523 | let open Bounds in 524 | let in_rect b = r >= b.r && c >= b.c && r < (b.r + b.h) && c < (b.c + b.w) in 525 | let get_signal_offset b = 526 | let r = r - b.r in 527 | let rec f row i = 528 | if i < Array.length state.W.waves then 529 | let _, wah = get_wave_height (state.cfg.wave_height, state.waves.(i)) in 530 | if r >= row && r < (row+wah) then i 531 | else f (row+wah) (i+1) 532 | else 533 | 0 (* better default? *) 534 | in 535 | f 0 state.cfg.start_signal 536 | in 537 | let get_wave_offset b = 538 | let c = c - b.c in 539 | let w, waw = get_wave_width (state.cfg.wave_width, Clock "") in 540 | let w_scale = get_w_scale w in 541 | ((c / waw) * w_scale) + state.cfg.start_cycle 542 | in 543 | if in_rect bounds.waves then Wave(get_wave_offset bounds.waves, get_signal_offset bounds.waves) 544 | else if in_rect bounds.values then Value(get_signal_offset bounds.values) 545 | else if in_rect bounds.signals then Signal(get_signal_offset bounds.signals) 546 | else if in_rect bounds.status then Status 547 | else No_pick 548 | 549 | end 550 | 551 | module Static(W : Wave.W) = struct 552 | module R = Make(Gfx.In_memory.Api)(W) 553 | 554 | let border_ext = function None -> 0 | Some _ -> 2 555 | 556 | let get_max_height border state = 557 | border_ext border + R.get_max_wave_height state state.W.cfg.W.start_signal 558 | 559 | let draw 560 | ?signals ?values ?waves ?(style=Styles.default Gfx.Style.default) 561 | ?rows ?cols state = 562 | (* inferred width and height *) 563 | let cols = match cols with None -> 80 | Some(x) -> x in 564 | let rows = match rows with None -> get_max_height style.Styles.border state | Some(x) -> x in 565 | 566 | (* do drawing *) 567 | let ctx = Gfx.In_memory.init ~rows ~cols in 568 | let bounds = Bounds.fit_to_window ?signals ?values ?waves Gfx.({r=0; c=0; h=rows; w=cols}) in 569 | R.draw_ui ~style ~ctx ~bounds state; 570 | 571 | (* return context *) 572 | ctx 573 | 574 | let draw_full ?(style=Styles.default Gfx.Style.default) state = 575 | let open Bounds in 576 | let open Styles in 577 | 578 | let bounds = R.get_max_bounds state in 579 | let ext = border_ext style.border in 580 | let get_ctx b = 581 | let open Gfx in 582 | let b = { b with w = b.w + ext; h = b.h + ext } in 583 | let ctx = Gfx.In_memory.init ~rows:b.h ~cols:b.w in 584 | let b = if ext=0 then b else Bounds.shrink_for_border b in 585 | b, ctx 586 | in 587 | 588 | let b, sctx = get_ctx bounds.signals in 589 | R.with_border ~draw:R.draw_signals 590 | ?border:style.border ~label:"Signals" 591 | ~style:style.signals ~ctx:sctx ~bounds:b state; 592 | 593 | let b, vctx = get_ctx bounds.values in 594 | ignore @@ R.with_border ~draw:R.draw_values 595 | ?border:style.border ~label:"Values" 596 | ~style:style.values ~ctx:vctx ~bounds:b state; 597 | 598 | let b, wctx = get_ctx bounds.waves in 599 | R.with_border ~draw:R.draw_wave 600 | ?border:style.border ~label:"Waves" 601 | ~style:style.waves ~ctx:wctx ~bounds:b state; 602 | 603 | sctx, vctx, wctx 604 | 605 | end 606 | 607 | -------------------------------------------------------------------------------- /src/render.mli: -------------------------------------------------------------------------------- 1 | module Styles : sig 2 | type t = 3 | { 4 | border : Gfx.Style.t option; 5 | signals : Gfx.Style.t; 6 | values : Gfx.Style.t; 7 | waves : Gfx.Style.t; 8 | status : Gfx.Style.t; 9 | } 10 | 11 | val default : Gfx.Style.t -> t 12 | val black_on_white : t 13 | val white_on_black : t 14 | val colour : t -> t 15 | val colour_on_white : t 16 | val colour_on_black : t 17 | end 18 | 19 | module Bounds : sig 20 | type t = 21 | { 22 | signals : Gfx.rect; 23 | values : Gfx.rect; 24 | waves : Gfx.rect; 25 | status : Gfx.rect; 26 | } 27 | val expand_for_border : Gfx.rect -> Gfx.rect 28 | val shrink_for_border : Gfx.rect -> Gfx.rect 29 | val fit_to_window : 30 | ?signals:bool -> ?values:bool -> ?waves:bool -> ?status:bool -> 31 | ?border:bool -> Gfx.rect -> t 32 | end 33 | 34 | (** Functions for drawing waves, signal names and values *) 35 | module Make (G : Gfx.Api) (W : Wave.W) : sig 36 | 37 | (** get width code and actual width in chars *) 38 | val get_wave_width : int * W.wave -> int * int 39 | 40 | (** get height code and actual height in chars *) 41 | val get_wave_height : int * W.wave -> int * int 42 | 43 | (** max width of name window *) 44 | val get_max_signal_width : W.waves -> int 45 | 46 | (** max width of values window *) 47 | val get_max_value_width : W.waves -> int 48 | 49 | (** max no of wave cycles *) 50 | val get_max_cycles : W.waves -> int 51 | 52 | (** max no of wave cycles *) 53 | val get_max_signals : W.waves -> int 54 | 55 | (** max width of wave window *) 56 | val get_max_wave_width : W.waves -> int 57 | 58 | (** max height of wave window *) 59 | val get_max_wave_height : W.waves -> int -> int 60 | 61 | (** draws one clock cycle *) 62 | val draw_clock_cycle : ctx:G.ctx -> style:G.style -> bounds:Gfx.rect -> 63 | w:int -> h:int -> c:int -> unit 64 | 65 | (** draws [cnt] clock cycles *) 66 | val draw_clock_cycles : ctx:G.ctx -> style:G.style -> bounds:Gfx.rect -> 67 | w:int -> waw:int -> h:int -> cnt:int -> unit 68 | 69 | (** draw binary waveform data *) 70 | val draw_binary_data : ctx:G.ctx -> style:G.style -> bounds:Gfx.rect -> 71 | w:int -> h:int -> data:W.t -> off:int -> unit 72 | 73 | (** draw arbitrary waveform data *) 74 | val draw_data : ctx:G.ctx -> style:G.style -> bounds:Gfx.rect -> to_str:(W.elt -> string) -> 75 | w:int -> h:int -> data:W.t -> off:int -> unit 76 | 77 | type 'a draw_item = ?style:Gfx.Style.t -> ctx:G.ctx -> bounds:Gfx.rect -> W.waves -> 'a 78 | 79 | val with_border : draw:'a draw_item -> label:string -> ?border:Gfx.Style.t -> 'a draw_item 80 | 81 | (** draw cursor *) 82 | val draw_cursor : ctx:G.ctx -> bounds:Gfx.rect -> state:W.waves -> unit 83 | 84 | (** draw waveforms *) 85 | val draw_wave : unit draw_item 86 | 87 | (** draw signal names *) 88 | val draw_signals : unit draw_item 89 | 90 | (** draw signal values *) 91 | val draw_values : int draw_item 92 | 93 | val draw_status : unit draw_item 94 | 95 | (** draw standard user inferface (names, values, waveforms left to right *) 96 | val draw_ui : 97 | ?style:Styles.t -> ?bounds:Bounds.t -> 98 | ctx:G.ctx -> W.waves -> unit 99 | 100 | type pick = 101 | | Wave of int * int 102 | | Value of int 103 | | Signal of int 104 | | Status 105 | | No_pick 106 | 107 | val pick : bounds:Bounds.t -> r:int -> c:int -> W.waves -> pick 108 | 109 | end 110 | 111 | module Static(W : Wave.W) : sig 112 | 113 | module R : module type of Make(Gfx.In_memory.Api)(W) 114 | 115 | val draw : 116 | ?signals:bool -> ?values:bool -> ?waves:bool -> ?style:Styles.t -> 117 | ?rows:int -> ?cols:int -> W.waves -> 118 | Gfx.In_memory.Api.ctx 119 | 120 | val draw_full : 121 | ?style:Styles.t -> W.waves -> 122 | Gfx.In_memory.Api.ctx * 123 | Gfx.In_memory.Api.ctx * 124 | Gfx.In_memory.Api.ctx 125 | 126 | end 127 | 128 | -------------------------------------------------------------------------------- /src/sim.ml: -------------------------------------------------------------------------------- 1 | (* connect to simulator *) 2 | open HardCaml 3 | 4 | module Make(B : Comb.S)(W : Wave.W with type elt = B.t) = struct 5 | 6 | open Cyclesim.Api 7 | 8 | let wrap ?cfg sim = 9 | 10 | let cycle = ref 0 in 11 | 12 | let compare = 13 | match cfg with 14 | | None -> compare 15 | | Some(s) -> 16 | let f = 17 | let s = List.mapi (fun i (n,_) -> n,i) s in 18 | (fun x -> try Some(List.assoc x s) with _ -> None) 19 | in 20 | (fun a b -> 21 | match f a, f b with 22 | | None, None -> compare a b 23 | | Some _, None -> -1 24 | | None, Some _ -> 1 25 | | Some(a), Some(b) -> compare a b) 26 | in 27 | 28 | let get_type = function 29 | | None -> (fun _ -> W.B) 30 | | Some(l) -> (fun n -> try List.assoc n l with _ -> W.B) 31 | in 32 | 33 | let port (n,v) = 34 | match n with 35 | | "clock" | "clk" -> W.Clock n, (fun _ -> ()) 36 | | "reset" | "rst" -> 37 | let d = W.make() in 38 | W.Binary(n, d), (fun v -> W.set d !cycle (if v then B.vdd else B.gnd)) 39 | | _ -> 40 | let t = get_type cfg n in 41 | let d = W.make () in 42 | let wave = 43 | if B.width !v = 1 && t = W.B then W.Binary(n, d) 44 | else W.Data(n, d, t) 45 | in 46 | wave, (fun _ -> W.set d !cycle !v) 47 | in 48 | 49 | let ports = List.concat [ 50 | List.map port (in_ports sim); 51 | List.map port (out_ports sim); 52 | List.map port (internal_ports sim); ] 53 | in 54 | 55 | let ports = List.sort (fun (w0,_) (w1,_) -> compare (W.get_name w0) (W.get_name w1)) ports in 56 | 57 | let waves = Array.of_list (List.map fst ports) in 58 | let updates = Array.of_list (List.map snd ports) in 59 | 60 | let tasks sim rst = fun () -> 61 | sim (); 62 | Array.iter (fun f -> f rst) updates; 63 | incr cycle 64 | in 65 | 66 | { sim with 67 | sim_reset = tasks sim.sim_reset true; 68 | sim_cycle_seq = tasks sim.sim_cycle_seq false; 69 | }, waves 70 | 71 | end 72 | 73 | -------------------------------------------------------------------------------- /src/sim.mli: -------------------------------------------------------------------------------- 1 | open HardCaml 2 | 3 | module Make(B : Comb.S)(W : Wave.W with type elt = B.t) : sig 4 | 5 | val wrap : 6 | ?cfg:(string * W.to_str) list -> 7 | B.t Cyclesim.Api.cyclesim -> 8 | B.t Cyclesim.Api.cyclesim * W.wave array 9 | 10 | end 11 | -------------------------------------------------------------------------------- /src/ui.ml: -------------------------------------------------------------------------------- 1 | module Make 2 | (B : HardCaml.Comb.S) 3 | (W : Wave.W with type elt = B.t) 4 | = struct 5 | 6 | open Lwt 7 | open LTerm_key 8 | open CamomileLibrary 9 | 10 | module G = Gfx_lterm.Api 11 | module R = Render.Make(G)(W) 12 | 13 | let show_status = true 14 | 15 | type state = 16 | { 17 | mutable bounds : Render.Bounds.t; 18 | waves : W.waves; 19 | } 20 | 21 | let rec loop ?timeout (ui,state) = 22 | let wait_ui = LTerm_ui.wait ui >>= fun ev -> Lwt.return (`event ev) in 23 | let sleepy time = Lwt_unix.sleep time >>= fun () -> Lwt.return `timeout in 24 | let process = function 25 | | `timeout -> LTerm_ui.draw ui; loop ?timeout (ui, state) 26 | | `event ev -> ui_event ?timeout (ui,state) ev 27 | in 28 | 29 | match timeout with 30 | | None -> wait_ui >>= process 31 | | Some(timeout) -> Lwt.pick [ sleepy timeout; wait_ui ] >>= process 32 | 33 | and ui_event ?timeout (ui, state) ev = 34 | let waves = state.waves in 35 | let open W in 36 | let draw_loop () = 37 | LTerm_ui.draw ui; 38 | loop ?timeout (ui,state) 39 | in 40 | match ev with 41 | (* quit *) 42 | | LTerm_event.Key{ code = Escape } -> 43 | return () 44 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = 'q' -> 45 | return () 46 | 47 | (* vertical scale *) 48 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '+' -> 49 | waves.cfg.wave_height <- waves.cfg.wave_height + 1; 50 | draw_loop () 51 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '_' -> 52 | waves.cfg.wave_height <- max 0 (waves.cfg.wave_height - 1); 53 | draw_loop () 54 | 55 | (* Horizontal scale *) 56 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '-' -> 57 | waves.cfg.wave_width <- waves.cfg.wave_width - 1; 58 | draw_loop () 59 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '=' -> 60 | waves.cfg.wave_width <- waves.cfg.wave_width + 1; 61 | draw_loop () 62 | 63 | (* cycle offset *) 64 | | LTerm_event.Key{ code = Home } -> 65 | waves.cfg.start_cycle <- 0; 66 | draw_loop () 67 | | LTerm_event.Key{ code = End } -> 68 | waves.cfg.start_cycle <- R.get_max_cycles waves - 1; 69 | draw_loop () 70 | | LTerm_event.Key{ code = Left; shift = true; control = false; meta = false } -> 71 | waves.cfg.start_cycle <- max 0 (waves.cfg.start_cycle - 10); 72 | draw_loop () 73 | | LTerm_event.Key{ code = Left; shift = false; control = false; meta = false } -> 74 | waves.cfg.start_cycle <- max 0 (waves.cfg.start_cycle - 1); 75 | draw_loop () 76 | | LTerm_event.Key{ code = Right; shift = true; control = false; meta = false } -> 77 | waves.cfg.start_cycle <- min (R.get_max_cycles waves - 1) 78 | (waves.cfg.start_cycle + 10); 79 | draw_loop () 80 | | LTerm_event.Key{ code = Right; shift = false; control = false; meta = false } -> 81 | waves.cfg.start_cycle <- min (R.get_max_cycles waves - 1) 82 | (waves.cfg.start_cycle + 1); 83 | draw_loop () 84 | 85 | (* signal offset *) 86 | | LTerm_event.Key{ code = Up; shift = true } -> 87 | waves.cfg.start_signal <- max 0 (waves.cfg.start_signal - 10); 88 | draw_loop () 89 | | LTerm_event.Key{ code = Up } -> 90 | waves.cfg.start_signal <- max 0 (waves.cfg.start_signal - 1); 91 | draw_loop () 92 | | LTerm_event.Key{ code = Down; shift = true } -> 93 | waves.cfg.start_signal <- min (R.get_max_signals waves - 1) 94 | (waves.cfg.start_signal + 10); 95 | draw_loop () 96 | | LTerm_event.Key{ code = Down } -> 97 | waves.cfg.start_signal <- min (R.get_max_signals waves - 1) 98 | (waves.cfg.start_signal + 1); 99 | draw_loop () 100 | 101 | (* signal/value window scroll *) 102 | | LTerm_event.Key{ code = Left; shift = false; control = true; meta = false } -> 103 | waves.cfg.signal_scroll <- max 0 (waves.cfg.signal_scroll - 1); 104 | draw_loop () 105 | | LTerm_event.Key{ code = Right; shift = false; control = true; meta = false } -> 106 | waves.cfg.signal_scroll <- waves.cfg.signal_scroll + 1; 107 | draw_loop () 108 | 109 | | LTerm_event.Key{ code = Left; shift = false; control = false; meta = true } -> 110 | waves.cfg.value_scroll <- max 0 (waves.cfg.value_scroll - 1); 111 | draw_loop () 112 | | LTerm_event.Key{ code = Right; shift = false; control = false; meta = true } -> 113 | waves.cfg.value_scroll <- waves.cfg.value_scroll + 1; 114 | draw_loop () 115 | 116 | (* terminal resize *) 117 | | LTerm_event.Resize size -> 118 | let bounds = Gfx.({r=0; c=0; w=size.LTerm_geom.cols; h=size.LTerm_geom.rows}) in 119 | state.bounds <- Render.Bounds.fit_to_window ~status:show_status bounds; 120 | draw_loop () 121 | 122 | (* mouse event *) 123 | | LTerm_event.Mouse m when LTerm_mouse.(m.button = Button1 && m.control) -> begin 124 | let open LTerm_mouse in 125 | begin 126 | match R.pick ~bounds:state.bounds ~r:m.row ~c:m.col waves with 127 | | R.Wave(cycle,signal) -> state.waves.cfg.start_cycle <- cycle; 128 | | R.Signal(signal) | R.Value(signal) -> state.waves.cfg.start_signal <- signal 129 | | _ -> () 130 | end; 131 | draw_loop () 132 | end 133 | 134 | | LTerm_event.Mouse m when LTerm_mouse.(m.button = Button1) -> begin 135 | let open LTerm_mouse in 136 | begin 137 | match R.pick ~bounds:state.bounds ~r:m.row ~c:m.col waves with 138 | | R.Wave(cycle,signal) -> state.waves.cfg.wave_cursor <- cycle 139 | | R.Signal(signal) | R.Value(signal) -> state.waves.cfg.signal_cursor <- signal 140 | | _ -> () 141 | end; 142 | draw_loop () 143 | end 144 | 145 | | ev -> 146 | loop ?timeout (ui, state) 147 | 148 | let sdef = Render.Styles.colour_on_black 149 | 150 | let init_state term waves = 151 | let size = LTerm.size term in 152 | let bounds = Gfx.({r=0; c=0; w=size.LTerm_geom.cols; h=size.LTerm_geom.rows}) in 153 | let bounds = Render.Bounds.fit_to_window ~status:show_status bounds in 154 | Lwt.return 155 | { 156 | bounds = bounds; 157 | waves = waves; 158 | } 159 | 160 | let draw style state ui matrix = 161 | let size = LTerm_ui.size ui in 162 | let ctx = LTerm_draw.context matrix size in 163 | R.draw_ui ~style ~ctx ~bounds:state.bounds state.waves 164 | 165 | let init ?(style=sdef) waves = 166 | Lazy.force LTerm.stdout >>= fun term -> 167 | LTerm.enable_mouse term >>= fun () -> 168 | (* initialization *) 169 | init_state term waves >>= fun state -> 170 | (* drawing functon *) 171 | LTerm_ui.create term (draw style state) >>= fun ui -> 172 | Lwt.return (ui,state,term) 173 | 174 | let run ?(style=sdef) ?timeout waves = 175 | init ~style waves >>= fun (ui,state,term) -> 176 | ((loop ?timeout (ui,state)) 177 | [%lwt.finally 178 | LTerm.disable_mouse term >>= fun () -> 179 | LTerm_ui.quit ui]) 180 | 181 | let run_testbench ?(style=sdef) ?timeout waves tb = 182 | let ui = run ~style ?timeout waves in 183 | try%lwt 184 | let%lwt tb = tb and () = ui >>= fun () -> (Lwt.cancel tb; Lwt.return ()) in 185 | Lwt.return (Some tb) 186 | with Lwt.Canceled -> 187 | Lwt.return None 188 | 189 | end 190 | -------------------------------------------------------------------------------- /src/ui.mli: -------------------------------------------------------------------------------- 1 | module Make (B : HardCaml.Comb.S) 2 | (W : Wave.W with type elt = B.t) : sig 3 | 4 | module G : Gfx.Api 5 | 6 | type state 7 | 8 | val loop : ?timeout:float -> (LTerm_ui.t * state) -> unit Lwt.t 9 | 10 | val init : 11 | ?style:Render.Styles.t -> 12 | W.waves -> (LTerm_ui.t * state * LTerm.t) Lwt.t 13 | 14 | (** Run wave viewer UI *) 15 | val run : 16 | ?style:Render.Styles.t -> 17 | ?timeout:float -> W.waves -> unit Lwt.t 18 | 19 | (** Run testbench and wave viewer UI. Returns None if UI is quit before 20 | the testbench completes. The UI will (optionally) update every [timeout] 21 | seconds. *) 22 | val run_testbench : 23 | ?style:Render.Styles.t -> 24 | ?timeout:float -> W.waves -> 'a Lwt.t -> 'a option Lwt.t 25 | 26 | end 27 | 28 | -------------------------------------------------------------------------------- /src/wave.ml: -------------------------------------------------------------------------------- 1 | (* element type *) 2 | module type E = sig 3 | type elt 4 | val zero : elt 5 | val one : elt 6 | val compare : elt -> elt -> bool 7 | val to_bstr : elt -> string 8 | val to_sstr : elt -> string 9 | val to_ustr : elt -> string 10 | val to_hstr : elt -> string 11 | val to_int : elt -> int 12 | end 13 | 14 | module type S = sig 15 | include E 16 | type t 17 | val length : t -> int 18 | val get : t -> int -> elt 19 | val init : int -> (int -> elt) -> t 20 | val make : unit -> t 21 | val set : t -> int -> elt -> unit 22 | end 23 | 24 | module Bits(B : HardCaml.Comb.S) = struct 25 | type elt = B.t 26 | let zero = B.gnd 27 | let one = B.vdd 28 | let compare a b = a = b 29 | 30 | (* string conversions *) 31 | let to_bstr = B.to_bstr 32 | 33 | let rec to_hstr b = 34 | let to_char i = 35 | Char.chr (if i < 10 then Char.code '0' + i else Char.code 'A' + i - 10) 36 | in 37 | let blen = B.width b in 38 | let slen = (blen + 3) / 4 in 39 | Bytes.init slen (fun i -> 40 | let i = slen - i - 1 in 41 | let l = i*4 in 42 | let h = (min blen (l+4)) - 1 in 43 | to_char (B.to_int (B.select b h l))) 44 | 45 | (* convert to integer using arbitrary precision. *) 46 | let to_ustr b = 47 | let max = 29 in (* safe max positive int bits *) 48 | if B.width b <= max then string_of_int (B.to_int b) 49 | else 50 | (* convert with big ints *) 51 | let rec f b acc = 52 | let (+:) = Big_int.add_big_int in 53 | let (<<:) = Big_int.shift_left_big_int in 54 | let to_big b = Big_int.big_int_of_int (B.to_int b) in 55 | if B.width b <= max then 56 | (* result *) 57 | (acc <<: (B.width b)) +: to_big b 58 | else 59 | let t, b = B.sel_top b max, B.drop_top b max in 60 | f b ((acc <<: max) +: to_big t) 61 | in 62 | Big_int.(string_of_big_int (f b zero_big_int)) 63 | 64 | (* signed conversion uses unsigned conversion with detection of sign *) 65 | let to_sstr b = 66 | let max = 29 in (* safe max positive int bits *) 67 | if B.width b <= max then string_of_int (B.to_sint b) 68 | else 69 | if B.to_int (B.msb b) = 0 then to_ustr b 70 | else 71 | "-" ^ (to_ustr B.((~: b) +:. 1)) (* conv -ve to +ve, leading '-' *) 72 | 73 | let to_int = B.to_int 74 | end 75 | 76 | module Make_dynamic(E : E) = struct 77 | include E 78 | 79 | type t = 80 | { 81 | mutable data : elt array; 82 | mutable length : int; 83 | } 84 | 85 | let length d = d.length 86 | 87 | let get d n = 88 | if n < d.length then 89 | Array.get d.data n 90 | else 91 | raise (Invalid_argument "wave out of bounds") 92 | 93 | let make () = 94 | { 95 | data = [||]; 96 | length = 0; 97 | } 98 | 99 | let init n f = 100 | { 101 | data = Array.init n f; 102 | length = n; 103 | } 104 | 105 | let resize d = 106 | let old_data = d.data in 107 | let new_len = max 1 (Array.length d.data * 2) in 108 | d.data <- Array.init new_len (fun i -> try old_data.(i) with _ -> zero) 109 | 110 | let rec set d n v = 111 | try begin 112 | Array.set d.data n v; 113 | d.length <- max d.length (n+1) 114 | end with _ -> begin 115 | resize d; 116 | set d n v 117 | end 118 | 119 | end 120 | 121 | module type W = sig 122 | 123 | include S 124 | 125 | type to_str = 126 | | B (* binary *) 127 | | H (* hex *) 128 | | U (* unsigned int *) 129 | | S (* signed int *) 130 | | F of (elt -> string) (* function *) 131 | | I of string list (* index into strings *) 132 | 133 | type wave = 134 | | Clock of string 135 | | Binary of string * t 136 | | Data of string * t * to_str 137 | 138 | val get_name : wave -> string 139 | val get_data : wave -> t 140 | val get_to_str : wave -> (elt -> string) 141 | 142 | type cfg = 143 | { 144 | mutable wave_width : int; 145 | mutable wave_height : int; 146 | mutable start_cycle : int; 147 | mutable start_signal : int; 148 | mutable wave_cursor : int; 149 | mutable signal_cursor : int; 150 | mutable signal_scroll : int; 151 | mutable value_scroll : int; 152 | } 153 | 154 | val default : cfg 155 | 156 | type waves = 157 | { 158 | cfg : cfg; 159 | waves : wave array; 160 | } 161 | 162 | val write : out_channel -> waves -> unit 163 | val read : in_channel -> waves 164 | 165 | end 166 | 167 | module Make(E : E) = struct 168 | 169 | module D = Make_dynamic(E) 170 | include D 171 | 172 | type to_str = 173 | | B (* binary *) 174 | | H (* hex *) 175 | | U (* unsigned int *) 176 | | S (* signed int *) 177 | | F of (elt -> string) (* function *) 178 | | I of string list (* index into strings *) 179 | 180 | type wave = 181 | | Clock of string 182 | | Binary of string * t 183 | | Data of string * t * to_str 184 | 185 | let get_name = function 186 | | Clock(n) -> n 187 | | Binary(n,_) -> n 188 | | Data(n,_,_) -> n 189 | 190 | let get_data = function 191 | | Clock(n) -> failwith "no clock data" 192 | | Binary(_,d) -> d 193 | | Data(_,d,_) -> d 194 | 195 | let get_to_str = function 196 | | Clock(n) -> failwith "no clock to_str" 197 | | Binary(_,_) -> failwith "no binary to_str" 198 | | Data(_,_,f) -> begin 199 | match f with 200 | | B -> to_bstr 201 | | H -> to_hstr 202 | | U -> to_ustr 203 | | S -> to_sstr 204 | | F f -> f 205 | | I s -> (fun elt -> try List.nth s (to_int elt) with _ -> "-") 206 | end 207 | 208 | type cfg = 209 | { 210 | mutable wave_width : int; 211 | mutable wave_height : int; 212 | mutable start_cycle : int; 213 | mutable start_signal : int; 214 | mutable wave_cursor : int; 215 | mutable signal_cursor : int; 216 | mutable signal_scroll : int; 217 | mutable value_scroll : int; 218 | } 219 | 220 | let default = 221 | { 222 | wave_width = 3; 223 | wave_height = 1; 224 | start_cycle = 0; 225 | start_signal = 0; 226 | wave_cursor = -1; 227 | signal_cursor = -1; 228 | signal_scroll = 0; 229 | value_scroll = 0; 230 | } 231 | 232 | type waves = 233 | { 234 | cfg : cfg; 235 | waves : wave array; 236 | } 237 | 238 | let write ch w = 239 | let w = 240 | { w with waves = Array.map 241 | (function 242 | | Clock(n) -> Clock(n) 243 | | Binary(n, d) -> 244 | Binary(n, { d with data=Array.init d.length (Array.get d.data); }) 245 | | Data(n, d, ts) -> 246 | let ts = match ts with F _ -> B | _ -> ts in (* cant marshal functions *) 247 | Data(n, { d with data=Array.init d.length (Array.get d.data); }, ts)) 248 | w.waves 249 | } 250 | in 251 | Marshal.to_channel ch w [] 252 | 253 | let read ch = (Marshal.from_channel ch : waves) 254 | (* 255 | let rle d = 256 | List.rev @@ Array.fold_left 257 | (fun acc x -> 258 | match acc with 259 | | [] -> [1,x] 260 | | (n,y)::t -> 261 | if E.compare x y then ((n+1,y)::t) else (1,x)::(n,y)::t) 262 | [] d 263 | 264 | (* XXX need a way to pack the elements *) 265 | 266 | let write_chunk ch w ~ofs ~size = 267 | (* extract the chunk *) 268 | let w = 269 | let init d = Array.init size (fun j -> Array.get d (j+ofs)) in 270 | { w with waves = Array.map 271 | (function 272 | | Clock(n) -> Clock(n) 273 | | Binary(n, d) -> 274 | Binary(n, { d with data=init d.data; }) 275 | | Data(n, d, ts) -> 276 | let ts = match ts with F _ -> B | _ -> ts in (* cant marshal functions *) 277 | Data(n, { d with data=init d.data; }, ts)) 278 | w.waves 279 | } 280 | in 281 | (* now compress the chunk *) 282 | w 283 | *) 284 | end 285 | 286 | 287 | 288 | 289 | -------------------------------------------------------------------------------- /src/wave.mli: -------------------------------------------------------------------------------- 1 | (* element type *) 2 | module type E = sig 3 | type elt 4 | val zero : elt 5 | val one : elt 6 | val compare : elt -> elt -> bool 7 | val to_bstr : elt -> string 8 | val to_sstr : elt -> string 9 | val to_ustr : elt -> string 10 | val to_hstr : elt -> string 11 | val to_int : elt -> int 12 | end 13 | 14 | module Bits(B : HardCaml.Comb.S) : E with type elt = B.t 15 | 16 | module type S = sig 17 | include E 18 | type t 19 | val length : t -> int 20 | val get : t -> int -> elt 21 | val init : int -> (int -> elt) -> t 22 | val make : unit -> t 23 | val set : t -> int -> elt -> unit 24 | end 25 | 26 | module type W = sig 27 | 28 | include S 29 | 30 | type to_str = 31 | | B (* binary *) 32 | | H (* hex *) 33 | | U (* unsigned int *) 34 | | S (* signed int *) 35 | | F of (elt -> string) (* function *) 36 | | I of string list (* index into strings *) 37 | 38 | type wave = 39 | | Clock of string 40 | | Binary of string * t 41 | | Data of string * t * to_str 42 | 43 | val get_name : wave -> string 44 | val get_data : wave -> t 45 | val get_to_str : wave -> (elt -> string) 46 | 47 | type cfg = 48 | { 49 | mutable wave_width : int; (** width of wave cycle *) 50 | mutable wave_height : int; (** height of wave cycle *) 51 | mutable start_cycle : int; (** start cycle *) 52 | mutable start_signal : int; (** start signal *) 53 | mutable wave_cursor : int; (** waveform cursor *) 54 | mutable signal_cursor : int; (** signal cursor *) 55 | mutable signal_scroll : int; 56 | mutable value_scroll : int; 57 | } 58 | 59 | val default : cfg 60 | 61 | type waves = 62 | { 63 | cfg : cfg; (** render config *) 64 | waves : wave array; (** data *) 65 | } 66 | 67 | val write : out_channel -> waves -> unit 68 | val read : in_channel -> waves 69 | 70 | end 71 | 72 | module Make(E : E) : W 73 | with type elt = E.elt 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/widget.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | module Make 4 | (B : HardCaml.Comb.S) 5 | (W : Wave.W with type elt = B.t) 6 | = struct 7 | 8 | open Render.Styles 9 | open Lwt 10 | open LTerm_key 11 | open LTerm_widget 12 | open LTerm_waveterm_compat 13 | open LTerm_geom 14 | open CamomileLibrary 15 | 16 | module G = Gfx_lterm.Api 17 | module R = Render.Make(G)(W) 18 | 19 | module Resources = struct 20 | 21 | open LTerm_resources 22 | open LTerm_style 23 | open Gfx.Style 24 | 25 | let get_colour k r = 26 | match String.Ascii.lowercase (get k r) with 27 | | "black" -> Some Black 28 | | "red" -> Some Red 29 | | "green" -> Some Green 30 | | "yellow" -> Some Yellow 31 | | "blue" -> Some Blue 32 | | "magenta" -> Some Magenta 33 | | "cyan" -> Some Cyan 34 | | "White" -> Some White 35 | | _ -> None 36 | 37 | let get_style k r = 38 | let fg = get_colour (k ^ ".foreground") r in 39 | let bg = get_colour (k ^ ".background") r in 40 | let bold = get_bool (k ^ ".bold") r in 41 | match fg, bg, bold with 42 | | None,None,None -> { fg=White; bg=Black; bold=false } 43 | | _ -> 44 | let fg = match fg with Some(c) -> c | None -> White in 45 | let bg = match bg with Some(c) -> c | None -> Black in 46 | let bold = match bold with Some(b) -> b | None -> false in 47 | { fg; bg; bold } 48 | 49 | end 50 | 51 | let no_state = W.({ cfg=default; waves=[||] }) 52 | 53 | let draw ~draw ?style ~ctx ?border ~focused state = 54 | let { rows; cols } = LTerm_draw.size ctx in 55 | let bounds = { Gfx.r=0; c=0; w=cols; h=rows } in 56 | draw ?style ~ctx ~bounds state 57 | 58 | class waves = object(self) 59 | inherit t "waveform.waves" as super 60 | 61 | val hscroll = new scrollable 62 | val vscroll = new scrollable 63 | method hscroll = hscroll 64 | method vscroll = vscroll 65 | 66 | method can_focus = true 67 | 68 | method size_request = {rows=0; cols=0} 69 | 70 | val mutable style = { white_on_black with border = None } 71 | method update_resources = 72 | let rc = self#resource_class and resources = self#resources in 73 | style <- { style with waves = Resources.get_style rc resources; } 74 | 75 | val mutable max_cycles = 0 76 | val mutable max_signals = 0 77 | val mutable state = W.({ cfg=default; waves=[||] }) 78 | 79 | method document_size = { rows=max_signals; cols=max_cycles } 80 | 81 | method page_size = 82 | let _, cycle_width = R.get_wave_width (state.W.cfg.W.wave_width, W.Clock "") in 83 | let alloc = size_of_rect self#allocation in 84 | let page_approx_width = 85 | int_of_float ((float_of_int alloc.cols /. float_of_int cycle_width) +. 0.5) 86 | in 87 | let page_approx_height = 88 | let total_height = float_of_int @@ R.get_max_wave_height state 0 in 89 | let page_height = float_of_int alloc.rows in 90 | let num_signals = float_of_int max_signals in 91 | max 0 (min max_signals @@ 92 | int_of_float ((page_height /. (total_height /. num_signals)) (*+. 0.5*))) 93 | in 94 | { rows = page_approx_height; 95 | cols = max 0 page_approx_width } 96 | 97 | method set_allocation r = 98 | super#set_allocation r; 99 | hscroll#set_document_size max_cycles; 100 | vscroll#set_document_size max_signals; 101 | let page_size = self#page_size in 102 | hscroll#set_page_size page_size.cols; 103 | vscroll#set_page_size page_size.rows 104 | 105 | method set_waves waves = 106 | state <- waves; 107 | max_cycles <- R.get_max_cycles state + 1; 108 | max_signals <- R.get_max_signals state; 109 | hscroll#set_document_size max_cycles; 110 | vscroll#set_document_size max_signals; 111 | let page_size = self#page_size in 112 | hscroll#set_page_size page_size.cols; 113 | vscroll#set_page_size page_size.rows 114 | 115 | method update_wave_cycles = 116 | let cycles = R.get_max_cycles state + 1 in 117 | if cycles <> max_cycles then begin 118 | max_cycles <- cycles; 119 | hscroll#set_document_size max_cycles 120 | end 121 | 122 | method private pick_event ev = 123 | let open LTerm_mouse in 124 | let open LTerm_key in 125 | 126 | let alloc = self#allocation in 127 | 128 | let pick m f = 129 | (* XXX yuk *) 130 | let bounds = 131 | let z = Gfx.({ r=0; c=0; w=0; h=0 }) in 132 | Render.Bounds.({ 133 | waves = Gfx.({ r=alloc.row1; c=alloc.col1; 134 | w=alloc.col2-alloc.col1; h=alloc.row2-alloc.row1 }); 135 | values=z; signals=z; status=z; 136 | }) 137 | in 138 | match R.pick ~bounds:bounds ~r:m.row ~c:m.col state with 139 | | R.Wave(cycle,signal) -> f cycle signal; true 140 | | _ -> false 141 | in 142 | 143 | match ev with 144 | 145 | (* cursor *) 146 | | LTerm_event.Mouse({button=Button1; control=false} as m) 147 | when in_rect alloc (coord m) -> 148 | pick m (fun cycle signal -> state.W.cfg.W.wave_cursor <- cycle) 149 | 150 | (* move to cycle *) 151 | | LTerm_event.Mouse({button=Button1; control=true} as m) 152 | when in_rect alloc (coord m) -> 153 | pick m (fun cycle signal -> hscroll#set_offset cycle) 154 | 155 | | _ -> false 156 | 157 | method wheel_event (hscroll : scrollable) ev = 158 | let open LTerm_mouse in 159 | match ev with 160 | (* mouse wheel *) 161 | | LTerm_event.Mouse {button=Button5; control; shift=false; meta=false} -> 162 | (if control then hscroll#set_offset hscroll#incr 163 | else vscroll#set_offset vscroll#incr); true 164 | | LTerm_event.Mouse {button=Button4; control; shift=false; meta=false} -> 165 | (if control then hscroll#set_offset hscroll#decr 166 | else vscroll#set_offset vscroll#decr); true 167 | 168 | | _ -> false 169 | 170 | method key_scroll_event (hscroll : scrollable) = function 171 | | LTerm_event.Key{code = Up; shift=true; control=false; meta=false} -> 172 | vscroll#set_offset vscroll#decr; self#queue_draw; true 173 | | LTerm_event.Key{code = Down; shift=true; control=false; meta=false} -> 174 | vscroll#set_offset vscroll#incr; self#queue_draw; true 175 | | LTerm_event.Key{code = Left; shift=true; control=false; meta=false} -> 176 | hscroll#set_offset hscroll#decr; self#queue_draw; true 177 | | LTerm_event.Key{code = Right; shift=true; control=false; meta=false} -> 178 | hscroll#set_offset hscroll#incr; self#queue_draw; true 179 | | LTerm_event.Key{code = Up; shift=false; control=true; meta=false} -> 180 | vscroll#set_offset (vscroll#offset-1); self#queue_draw; true 181 | | LTerm_event.Key{code = Down; shift=false; control=true; meta=false} -> 182 | vscroll#set_offset (vscroll#offset+1); self#queue_draw; true 183 | | LTerm_event.Key{code = Left; shift=false; control=true; meta=false} -> 184 | hscroll#set_offset (hscroll#offset-1); self#queue_draw; true 185 | | LTerm_event.Key{code = Right; shift=false; control=true; meta=false} -> 186 | hscroll#set_offset (hscroll#offset+1); self#queue_draw; true 187 | | _ -> false 188 | 189 | method scale_event = function 190 | (* vertical scale *) 191 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '+' -> 192 | state.W.cfg.W.wave_height <- state.W.cfg.W.wave_height + 1; 193 | let page_size = self#page_size in 194 | hscroll#set_page_size page_size.cols; 195 | vscroll#set_page_size page_size.rows; 196 | self#queue_draw; true 197 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '_' -> 198 | state.W.cfg.W.wave_height <- max 0 (state.W.cfg.W.wave_height - 1); 199 | let page_size = self#page_size in 200 | hscroll#set_page_size page_size.cols; 201 | vscroll#set_page_size page_size.rows; 202 | self#queue_draw; true 203 | 204 | (* Horizontal scale *) 205 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '-' -> 206 | state.W.cfg.W.wave_width <- state.W.cfg.W.wave_width - 1; 207 | let page_size = self#page_size in 208 | hscroll#set_page_size page_size.cols; 209 | vscroll#set_page_size page_size.rows; 210 | self#queue_draw; true 211 | | LTerm_event.Key{ code = Char c } when UChar.char_of c = '=' -> 212 | state.W.cfg.W.wave_width <- state.W.cfg.W.wave_width + 1; 213 | let page_size = self#page_size in 214 | hscroll#set_page_size page_size.cols; 215 | vscroll#set_page_size page_size.rows; 216 | self#queue_draw; true 217 | 218 | | _ -> false 219 | 220 | initializer self#on_event @@ fun ev -> 221 | self#wheel_event hscroll ev || 222 | self#key_scroll_event hscroll ev || 223 | self#scale_event ev || 224 | self#pick_event ev 225 | 226 | method draw ctx focused = 227 | let focused = focused = (self :> t) in 228 | state.W.cfg.W.start_cycle <- hscroll#offset; 229 | state.W.cfg.W.start_signal <- vscroll#offset; 230 | draw ~draw:R.draw_wave 231 | ~style:style.waves ~ctx ?border:style.border ~focused state 232 | 233 | end 234 | 235 | class signals cols wave = object(self) 236 | inherit t "waveform.signals" as super 237 | 238 | val vscroll = wave#vscroll 239 | val hscroll = new scrollable 240 | method hscroll = hscroll 241 | 242 | method can_focus = true 243 | 244 | val mutable max_signal_width = 0 245 | val mutable max_signals = 0 246 | val mutable state = W.({ cfg=default; waves=[||] }) 247 | 248 | method size_request = { rows=0; cols } 249 | 250 | val mutable size = { cols=0; rows=0 } 251 | method set_allocation r = 252 | size <- size_of_rect r; 253 | super#set_allocation r; 254 | hscroll#set_document_size max_signal_width; 255 | hscroll#set_page_size size.cols 256 | 257 | method set_waves waves = 258 | state <- waves; 259 | max_signal_width <- R.get_max_signal_width state; 260 | max_signals <- R.get_max_signals state; 261 | hscroll#set_document_size max_signal_width; 262 | hscroll#set_page_size size.cols 263 | 264 | val mutable style = { white_on_black with border = None } 265 | method update_resources = 266 | let rc = self#resource_class and resources = self#resources in 267 | style <- { style with signals = Resources.get_style rc resources; } 268 | 269 | method draw ctx focused = 270 | let focused = focused = (self :> t) in 271 | state.W.cfg.W.signal_scroll <- hscroll#offset; 272 | state.W.cfg.W.start_signal <- vscroll#offset; 273 | draw ~draw:R.draw_signals 274 | ~style:style.signals ~ctx ?border:style.border ~focused state 275 | 276 | initializer self#on_event 277 | (fun ev -> wave#wheel_event hscroll ev || 278 | wave#key_scroll_event hscroll ev || 279 | wave#scale_event ev) 280 | 281 | end 282 | 283 | class values cols wave = object(self) 284 | inherit t "waveform.values" as super 285 | 286 | val vscroll = wave#vscroll 287 | val hscroll = new scrollable 288 | method hscroll = hscroll 289 | 290 | method can_focus = true 291 | 292 | val mutable max_value_width = 0 293 | val mutable max_signals = 0 294 | val mutable state = W.({ cfg=default; waves=[||] }) 295 | 296 | method private set_max_value_width w = 297 | if w > max_value_width then begin 298 | let diff = w - max_value_width in 299 | max_value_width <- w; 300 | hscroll#set_document_size max_value_width; 301 | hscroll#set_offset (hscroll#offset + diff); 302 | end 303 | 304 | method size_request = { rows=0; cols } 305 | 306 | val mutable size = { cols=0; rows=0 } 307 | method set_allocation r = 308 | size <- size_of_rect r; 309 | super#set_allocation r; 310 | hscroll#set_page_size size.cols; 311 | self#set_max_value_width size.cols; 312 | hscroll#set_offset 0 313 | 314 | method set_waves waves = 315 | state <- waves; 316 | max_value_width <- 0; 317 | max_signals <- R.get_max_signals state; 318 | hscroll#set_page_size size.cols; 319 | self#set_max_value_width size.cols; 320 | hscroll#set_offset 0 321 | 322 | val mutable style = { white_on_black with border = None } 323 | method update_resources = 324 | let rc = self#resource_class and resources = self#resources in 325 | style <- { style with values = Resources.get_style rc resources; } 326 | 327 | method draw ctx focused = 328 | let focused = focused = (self :> t) in 329 | state.W.cfg.W.value_scroll <- hscroll#range - hscroll#offset - 1; 330 | state.W.cfg.W.start_signal <- vscroll#offset; 331 | self#set_max_value_width @@ 332 | draw ~draw:R.draw_values 333 | ~style:style.values ~ctx ?border:style.border ~focused state 334 | 335 | initializer self#on_event 336 | (fun ev -> wave#wheel_event hscroll ev || 337 | wave#key_scroll_event hscroll ev || 338 | wave#scale_event ev) 339 | 340 | end 341 | 342 | class status = object(self) 343 | inherit t "waveform.status" 344 | 345 | method can_focus = false 346 | 347 | method size_request = {rows=1; cols=0} 348 | 349 | val mutable style = { white_on_black with border = None } 350 | method update_resources = 351 | let rc = self#resource_class and resources = self#resources in 352 | style <- { style with status = Resources.get_style rc resources; } 353 | 354 | val mutable state = W.({ cfg=default; waves=[||] }) 355 | method set_waves wave = state <- wave 356 | 357 | method draw ctx focused = 358 | let focused = focused = (self :> t) in 359 | draw ~draw:R.draw_status 360 | ~style:style.status ~ctx ?border:style.border ~focused state 361 | 362 | end 363 | 364 | let button txt = new LTerm_waveterm_compat.Button.button ~brackets:("","") txt 365 | 366 | let add_scroll name framed wheel widget = 367 | let vbox = new vbox in 368 | let frame = 369 | if framed then 370 | let frame = new LTerm_waveterm_compat.Frame.frame in 371 | frame#set_label name; 372 | frame#set widget; 373 | (frame :> t) 374 | else 375 | (widget :> t) 376 | in 377 | let bl, br = button "←", button "→" in 378 | let hbox = new hbox in 379 | let hscroll = new hscrollbar ~height:1 widget#hscroll in 380 | hscroll#on_event (wheel widget#hscroll); 381 | bl#on_click (fun () -> widget#hscroll#set_offset (widget#hscroll#offset-1)); 382 | br#on_click (fun () -> widget#hscroll#set_offset (widget#hscroll#offset+1)); 383 | hbox#add ~expand:false bl; 384 | hbox#add hscroll; 385 | hbox#add ~expand:false br; 386 | vbox#add ~expand:true frame; 387 | vbox#add ~expand:false hbox; 388 | vbox 389 | 390 | class waveform ?(signals_width=20) ?(values_width=20) ?(framed=true) () = 391 | let wave' = new waves in 392 | let signal' = new signals signals_width wave' in 393 | let value' = new values values_width wave' in 394 | 395 | let signal = add_scroll "Signals" framed wave'#wheel_event signal' in 396 | let value = add_scroll "Values" framed wave'#wheel_event value' in 397 | let wave = add_scroll "Waves" framed wave'#wheel_event wave' in 398 | 399 | let vscroll = new vscrollbar ~width:1 wave'#vscroll in 400 | let () = vscroll#on_event (wave'#wheel_event wave'#hscroll) in 401 | let bu, bd = button "↑", button "↓" in 402 | let vbox = new vbox in 403 | let () = bu#on_click (fun () -> wave'#vscroll#set_offset (wave'#vscroll#offset-1)) in 404 | let () = bd#on_click (fun () -> wave'#vscroll#set_offset (wave'#vscroll#offset+1)) in 405 | let () = vbox#add ~expand:false bu in 406 | let () = vbox#add ~expand:true vscroll in 407 | let () = vbox#add ~expand:false bd in 408 | let () = vbox#add ~expand:false (new LTerm_waveterm_compat.Spacing.spacing ~rows:1 ~cols:1 ()) in 409 | 410 | object(self) 411 | inherit hbox as hbox 412 | initializer 413 | hbox#add ~expand:false signal; 414 | if not framed then hbox#add ~expand:false (new vline); 415 | hbox#add ~expand:false value; 416 | if not framed then hbox#add ~expand:false (new vline); 417 | hbox#add ~expand:true wave; 418 | hbox#add ~expand:false vbox 419 | 420 | val mutable state = no_state 421 | 422 | method waves = wave' 423 | method signals = signal' 424 | method values = value' 425 | 426 | method set_waves ?(keep_cfg=false) waves = 427 | state <- 428 | (if keep_cfg then W.({ waves with cfg = state.cfg }) 429 | else waves); 430 | wave'#set_waves state; 431 | signal'#set_waves state; 432 | value'#set_waves state 433 | 434 | method get_waves = state 435 | 436 | method update_wave_cycles = wave'#update_wave_cycles 437 | 438 | end 439 | 440 | (* run the user interface. *) 441 | let run_widget ?exit (widget : #t) = 442 | let waiter, wakener = 443 | match exit with 444 | | None -> wait () 445 | | Some(a,b) -> a,b 446 | in 447 | widget#on_event (function 448 | LTerm_event.Key{LTerm_key.code=LTerm_key.Escape} -> 449 | wakeup wakener (); false | _ -> false); 450 | Lazy.force LTerm.stdout >>= fun term -> 451 | LTerm.enable_mouse term >>= fun () -> 452 | Lwt.finalize 453 | (fun () -> LTerm_widget.run term widget waiter) 454 | (fun () -> LTerm.disable_mouse term) 455 | 456 | let run_widget_testbench ?exit (widget : #t) tb = 457 | let ui = run_widget ?exit widget in 458 | try%lwt 459 | let%lwt tb = tb and () = ui >>= fun () -> (Lwt.cancel tb; Lwt.return ()) in 460 | Lwt.return (Some tb) 461 | with Lwt.Canceled -> 462 | Lwt.return None 463 | 464 | let run waves = 465 | let waveform = new waveform () in 466 | waveform#set_waves waves; 467 | run_widget waveform 468 | 469 | let run_testbench waves tb = 470 | let waveform = new waveform () in 471 | waveform#set_waves waves; 472 | run_widget_testbench waveform tb 473 | 474 | end 475 | -------------------------------------------------------------------------------- /src/widget.mli: -------------------------------------------------------------------------------- 1 | module Make 2 | (B : HardCaml.Comb.S) 3 | (W : Wave.W with type elt = B.t) 4 | : sig 5 | 6 | module G : module type of Gfx_lterm.Api 7 | module R : module type of Render.Make(G)(W) 8 | 9 | class waves : object 10 | inherit LTerm_widget.t 11 | method set_waves : W.waves -> unit 12 | method hscroll : LTerm_waveterm_compat.scrollable 13 | method vscroll : LTerm_waveterm_compat.scrollable 14 | method document_size : LTerm_geom.size 15 | method update_wave_cycles : unit 16 | method page_size : LTerm_geom.size 17 | method wheel_event : LTerm_waveterm_compat.scrollable -> LTerm_event.t -> bool 18 | method scale_event : LTerm_event.t -> bool 19 | method key_scroll_event : LTerm_waveterm_compat.scrollable -> LTerm_event.t -> bool 20 | end 21 | 22 | class signals : int -> waves -> object 23 | inherit LTerm_widget.t 24 | method set_waves : W.waves -> unit 25 | method hscroll : LTerm_waveterm_compat.scrollable 26 | end 27 | 28 | class values : int -> waves -> object 29 | inherit LTerm_widget.t 30 | method set_waves : W.waves -> unit 31 | method hscroll : LTerm_waveterm_compat.scrollable 32 | end 33 | 34 | class status : object 35 | inherit LTerm_widget.t 36 | method set_waves : W.waves -> unit 37 | end 38 | 39 | class waveform : ?signals_width:int -> ?values_width:int -> ?framed:bool -> unit -> object 40 | inherit LTerm_widget.hbox 41 | method waves : waves 42 | method values : values 43 | method signals : signals 44 | method set_waves : ?keep_cfg:bool -> W.waves -> unit 45 | method get_waves : W.waves 46 | method update_wave_cycles : unit 47 | end 48 | 49 | val run_widget : ?exit:(unit Lwt.t * unit Lwt.u) -> #LTerm_widget.t -> unit Lwt.t 50 | 51 | val run_widget_testbench : ?exit:(unit Lwt.t * unit Lwt.u) -> #LTerm_widget.t -> 52 | 'a Lwt.t -> 'a option Lwt.t 53 | 54 | val run : W.waves -> unit Lwt.t 55 | 56 | val run_testbench : W.waves -> 'a Lwt.t -> 'a option Lwt.t 57 | 58 | end 59 | 60 | 61 | -------------------------------------------------------------------------------- /src/write.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | type styler = 4 | { 5 | start : (string -> unit) -> unit; 6 | set : (string -> unit) -> Gfx.Style.t -> unit; 7 | eol : (string -> unit) -> unit; 8 | finish : (string -> unit) -> unit; 9 | } 10 | 11 | let no_styler = 12 | { 13 | start = (fun _ -> ()); 14 | set = (fun _ _ -> ()); 15 | eol = (fun _ -> ()); 16 | finish = (fun _ -> ()); 17 | } 18 | 19 | open Gfx.Style 20 | 21 | let str_of_colour = function 22 | | Black -> "black" | Red -> "red" | Green -> "green" | Yellow -> "yellow" 23 | | Blue -> "blue" | Magenta -> "magenta" | Cyan -> "cyan" | White -> "white" 24 | 25 | let int_of_colour = function 26 | | Black -> 0 | Red -> 1 | Green -> 2 | Yellow -> 3 27 | | Blue -> 4 | Magenta -> 5 | Cyan -> 6 | White -> 7 28 | 29 | let html_styler = 30 | let prev = ref default in 31 | let set_style style os = 32 | os (Printf.sprintf "" 33 | (str_of_colour style.bg) (str_of_colour style.fg) 34 | (if style.bold then "bold" else "normal")) 35 | in 36 | let close_style os = os "" in 37 | { 38 | start = (fun os -> prev := default; set_style default os); 39 | set = (fun os style -> 40 | if style <> !prev then begin 41 | prev := style; close_style os; set_style style os 42 | end); 43 | eol = (fun _ -> ()); 44 | finish = close_style; 45 | } 46 | 47 | let css_class_styler = 48 | let prev = ref default in 49 | let set_style style os = 50 | os (Printf.sprintf "" 51 | (int_of_colour style.bg) (int_of_colour style.fg) 52 | (if style.bold then "b" else "")) 53 | in 54 | let close_style os = os "" in 55 | { 56 | start = (fun os -> prev := default; set_style default os); 57 | set = (fun os style -> 58 | if style <> !prev then begin 59 | prev := style; close_style os; set_style style os 60 | end); 61 | eol = (fun _ -> ()); 62 | finish = close_style; 63 | } 64 | 65 | let css_classes = 66 | let css fg bg b = 67 | Printf.sprintf ".w%i%i%s { background-color:%s; color:%s; font-wieght:%s; }" 68 | (int_of_colour bg) (int_of_colour fg) (if b then "b" else "") 69 | (str_of_colour bg) (str_of_colour fg) (if b then "bold" else "normal") 70 | in 71 | let colours = [ Black; Red; Green; Yellow; Blue; Magenta; Cyan; White ] in 72 | let mapcat f = String.concat ~sep:"\n" (List.map f colours) in 73 | mapcat (fun fg -> mapcat (fun bg -> css fg bg false ^ "\n" ^ css fg bg true)) 74 | 75 | let term_styler = 76 | let prev = ref None in 77 | let set_style style os = 78 | os (Printf.sprintf "\027[%i;%i%sm" 79 | (int_of_colour style.bg + 40) (int_of_colour style.fg + 30) 80 | (if style.bold then ";1" else "")) 81 | in 82 | let close_style os = os "\027[0m" in 83 | { 84 | start = (fun os -> prev := None); 85 | set = 86 | (fun os style -> 87 | let set_style () = prev := Some style; set_style style os in 88 | match !prev with 89 | | Some(prev') when style <> prev' -> set_style () 90 | | None -> set_style () 91 | | _ -> ()); 92 | eol = (fun os -> prev := None; close_style os); 93 | finish = close_style; 94 | } 95 | 96 | let html_escape ?(styler=no_styler) os ctx = 97 | let open Gfx in 98 | let open In_memory in 99 | let bounds = Api.get_bounds ctx in 100 | styler.start os; 101 | for r=0 to bounds.h-1 do 102 | for c=0 to bounds.w-1 do (* TODO styling *) 103 | let code = fst ctx.(r).(c) in 104 | styler.set os (snd ctx.(r).(c)); 105 | os ("&#" ^ string_of_int code) 106 | done; 107 | styler.eol os; 108 | os "\n" 109 | done; 110 | styler.finish os 111 | 112 | let utf8 ?(styler=no_styler) os ctx = 113 | let open Gfx in 114 | let open In_memory in 115 | let put c = 116 | if c <= 0x7f then begin os (Bytes.init 1 (fun _ -> Char.of_byte c)) 117 | end else if c <= 0x7FF then begin 118 | os (Bytes.init 2 (function 119 | | 0 -> Char.of_byte ((c lsr 6) lor 0b11000000) 120 | | _ -> Char.of_byte ((c land 0b00111111) lor 0b10000000))) 121 | end else if c <= 0xFFFF then begin 122 | os (Bytes.init 3 (function 123 | | 0 -> Char.of_byte ((c lsr 12) lor 0b11100000) 124 | | 1 -> Char.of_byte (((c lsr 6) land 0b00111111) lor 0b10000000) 125 | | _ -> Char.of_byte ((c land 0b00111111) lor 0b10000000))) 126 | end else 127 | failwith "extend utf-8 writer!" 128 | in 129 | let bounds = Api.get_bounds ctx in 130 | styler.start os; 131 | for r=0 to bounds.h-1 do 132 | for c=0 to bounds.w-1 do 133 | styler.set os (snd ctx.(r).(c)); 134 | put (fst ctx.(r).(c)) 135 | done; 136 | styler.eol os; 137 | os "\n" 138 | done; 139 | styler.finish os 140 | 141 | -------------------------------------------------------------------------------- /src/write.mli: -------------------------------------------------------------------------------- 1 | (** stylting functions *) 2 | type styler = 3 | { 4 | start : (string -> unit) -> unit; (** called at start *) 5 | set : (string -> unit) -> Gfx.Style.t -> unit; (** called for each element *) 6 | eol : (string -> unit) -> unit; (** called at end of each line *) 7 | finish : (string -> unit) -> unit; (** called at end *) 8 | } 9 | 10 | (** not styling information inserted *) 11 | val no_styler : styler 12 | 13 | (** Inline CSS per span element *) 14 | val html_styler : styler 15 | 16 | (** CSS specified with classes *) 17 | val css_class_styler : styler 18 | 19 | (** CSS classes for [css_class_styler]. Dump in CSS file or style tag. *) 20 | val css_classes : string 21 | 22 | (** ANSI termianl escape codes *) 23 | val term_styler : styler 24 | 25 | (** write data as html escape code *) 26 | val html_escape : ?styler:styler -> (string -> unit) -> Gfx.In_memory.Api.ctx -> unit 27 | 28 | (** write data as utf-8 *) 29 | val utf8 : ?styler:styler -> (string -> unit) -> Gfx.In_memory.Api.ctx -> unit 30 | 31 | -------------------------------------------------------------------------------- /test/data-render.wave: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ujamjar/hardcaml-waveterm/8f1be28f22d0d98cc6c4424ef55b79a873e93c3c/test/data-render.wave -------------------------------------------------------------------------------- /test/genwave.ml: -------------------------------------------------------------------------------- 1 | (* $ utop "test/genwave.ml" *) 2 | (*#directory "_build/src" 3 | #require "hardcaml" 4 | #load "HardCamlWaveTerm.cma"*) 5 | 6 | open HardCamlWaveTerm 7 | open HardCaml 8 | 9 | module B = Bits.Comb.IntbitsList 10 | module W = Wave.Make(Wave.Bits(B)) 11 | 12 | (* generate data patterns *) 13 | let rand length bits = W.init length (fun _ -> B.srand bits) 14 | let toggle length n bits = W.init length 15 | (fun i -> if (i/n) mod 2 = 0 then B.consti bits 0 else B.consti bits 1) 16 | let count length bits = W.init length (B.consti bits) 17 | 18 | let cycles = 50 19 | 20 | let wave_toggle = 21 | W.({ 22 | cfg = default; 23 | waves = [| 24 | W.Clock "clock"; 25 | W.Binary("b1", toggle cycles 1 1); 26 | W.Data ("d1", toggle cycles 1 1, W.B); 27 | W.Binary("b2", toggle cycles 2 1); 28 | W.Data ("d2", toggle cycles 2 1, W.B); 29 | W.Binary("b3", toggle cycles 3 1); 30 | W.Data ("d3", toggle cycles 3 1, W.B); 31 | W.Binary("b4", toggle cycles 4 1); 32 | W.Data ("d4", toggle cycles 4 1, W.B); 33 | |]; 34 | }) 35 | 36 | let wave_data_render = 37 | W.({ 38 | cfg = { default with 39 | wave_width = 8; 40 | wave_height = 4; 41 | start_cycle = 10; 42 | start_signal = 0; 43 | }; 44 | waves = [| 45 | W.Clock "clock"; 46 | W.Data("binary", rand cycles 2, W.B); 47 | W.Data("hex", rand cycles 9, W.H); 48 | W.Data("unsigned", rand cycles 5, W.U); 49 | W.Data("signed", rand cycles 5, W.S); 50 | W.Data("index ", rand cycles 2, W.I ["One";"Two";"Three";"Four"]); 51 | W.Data("function", rand cycles 4, W.F (fun e -> if B.to_int e > 90 then ">10" else "")); 52 | |]; 53 | }) 54 | 55 | let wave_name = 56 | W.({ 57 | cfg = default; 58 | waves = [| 59 | W.Clock "clock"; 60 | W.Data("aaaa_bbbb_cccc_dd", rand cycles 22, W.B); 61 | W.Data("aaaa_bbbb_cccc_ddd", rand cycles 19, W.B); 62 | W.Data("aaaa_bbbb_cccc_dddd", rand cycles 18, W.B); 63 | W.Data("aaaa_bbbb_cccc_dddd_eeee_ffff", rand cycles 17, W.B); 64 | |]; 65 | }) 66 | 67 | let wave_big = 68 | W.({ 69 | cfg = default; 70 | waves = Array.init 100 (fun i -> W.Data("s"^string_of_int i, rand 1000 (Random.int 50 + 1), W.B)); 71 | }) 72 | 73 | let write_wave n w = 74 | let f = open_out n in 75 | W.write f w; 76 | close_out f 77 | 78 | let () = write_wave "test/toggle.wave" wave_toggle 79 | let () = write_wave "test/data-render.wave" wave_data_render 80 | let () = write_wave "test/name.wave" wave_name 81 | let () = write_wave "test/big.wave" wave_big 82 | 83 | -------------------------------------------------------------------------------- /test/index.html: -------------------------------------------------------------------------------- 1 | 
 2 | ┌Signals─┐┌Values──┐┌Waves─────────────────────────────────────────────────────┐
 3 | │clock   ││        ││┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌─│
 4 | │        ││        ││    └───┘   └───┘   └───┘   └───┘   └───┘   └───┘   └───┘ │
 5 | │a       ││0       ││                ┌───────┐       ┌───────┐               ┌─│
 6 | │        ││        ││────────────────┘       └───────┘       └───────────────┘ │
 7 | │        ││        ││────────┬───────┬───────┬───────┬───────┬───────┬───────┬─│
 8 | │b       ││-318    ││ -318   │-131   │387    │-33    │-69    │-5     │-463   │3│
 9 | │        ││        ││────────┴───────┴───────┴───────┴───────┴───────┴───────┴─│
10 | │c       ││0       ││                ┌───────────────┐                       ┌─│
11 | │        ││        ││────────────────┘               └───────────────────────┘ │
12 | │        ││        ││────────────────┬───────┬───────┬───────┬───────┬───────┬─│
13 | │gamma-om││1       ││ 1              │9      │8      │4      │6      │5      │0│
14 | │        ││        ││────────────────┴───────┴───────┴───────┴───────┴───────┴─│
15 | │        ││        ││────────┬───────┬───────┬───────────────────────────────┬─│
16 | │beta    ││0       ││ 0      │2      │1      │0                              │2│
17 | │        ││        ││────────┴───────┴───────┴───────────────────────────────┴─│
18 | │delta   ││1       ││────────┐       ┌───────┐       ┌───────┐       ┌───────┐ │
19 | │        ││        ││        └───────┘       └───────┘       └───────┘       └─│
20 | │eye     ││0       ││        ┌───────┐                               ┌─────────│
21 | │        ││        ││────────┘       └───────────────────────────────┘         │
22 | │        ││        ││────────┬───────┬───────┬───────┬───────┬───────────────┬─│
23 | │enable  ││1       ││ 1      │-4     │-1     │3      │1      │-4             │-│
24 | │        ││        ││────────┴───────┴───────┴───────┴───────┴───────────────┴─│
25 | │clock2  ││        ││┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌─│
26 | │        ││        ││    └───┘   └───┘   └───┘   └───┘   └───┘   └───┘   └───┘ │
27 | │        ││        ││────────┬───────┬───────┬───────┬───────────────┬───────┬─│
28 | │bubble  ││-2      ││ -2     │8      │-6     │1      │-1             │6      │-│
29 | │        ││        ││────────┴───────┴───────┴───────┴───────────────┴───────┴─│
30 | │fairy   ││0       ││        ┌───────┐       ┌───────────────┐                 │
31 | │        ││        ││────────┘       └───────┘               └─────────────────│
32 | └────────┘└────────┘└──────────────────────────────────────────────────────────┘
33 |
-------------------------------------------------------------------------------- /test/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((names (testsim testsim_lwt testwidget testwidget_lwt)) 5 | (libraries (hardcaml-waveterm)) 6 | (preprocess (action (run bodge_ppx.sh ppx_lwt ${<}))))) 7 | 8 | -------------------------------------------------------------------------------- /test/testsim.ml: -------------------------------------------------------------------------------- 1 | (* Demonstrate a standard HardCaml testbench with a generated waveform 2 | written to the terminal. 3 | 4 | We use 'HardCamlWaveTerm.Sim.Make(B).wrap' to hook into the simulation 5 | and generate the waveform data. 6 | 7 | When the sim has finished the Write.uft8 function prints the wave to stdout. 8 | We also display the interactive UI. 9 | 10 | This flow might be useful in, for example, utop or iocaml notebooks. 11 | Note that you can render multiple times and at any point during the 12 | simulation to capture interesting data. 13 | *) 14 | 15 | open HardCaml.Api 16 | open Comb 17 | 18 | open HardCamlWaveTerm 19 | module W = Wave.Make(Wave.Bits(B)) 20 | module Ws = Sim.Make(B)(W) 21 | module R = Render.Static(W) 22 | 23 | module Ui = HardCamlWaveTerm.Ui.Make(B)(W) 24 | 25 | module I = struct 26 | type 'a t = { 27 | a : 'a [@bits 4]; 28 | b : 'a [@bits 4]; 29 | }[@@deriving hardcaml] 30 | end 31 | module O = struct 32 | type 'a t = { 33 | c : 'a [@bits 4]; 34 | }[@@deriving hardcaml] 35 | end 36 | 37 | open I 38 | open O 39 | 40 | let f i = 41 | { c = i.a +: i.b } 42 | 43 | module G = Interface.Gen(I)(O) 44 | 45 | let circ,sim,i,o,_ = G.make "test" f 46 | let sim, waves = Ws.wrap sim 47 | let () = 48 | Cs.reset sim; 49 | for l=0 to 7 do 50 | for m=0 to 7 do 51 | i.a := B.consti 4 l; 52 | i.b := B.consti 4 m; 53 | Cs.cycle sim; 54 | done; 55 | done 56 | 57 | let waves = W.({ cfg=default; waves }) 58 | 59 | (* show data in terminal *) 60 | let () = 61 | let open HardCamlWaveTerm in 62 | Write.(utf8 ~styler:term_styler print_string 63 | (R.(draw ~style:Render.Styles.colour_on_black ~cols:200 waves))) 64 | 65 | (* show user interface *) 66 | let%lwt () = Ui.run waves 67 | 68 | -------------------------------------------------------------------------------- /test/testsim_lwt.ml: -------------------------------------------------------------------------------- 1 | (* This shows a LWT-ified HardCaml testbench which is run in parallel with 2 | the interactive waveform viewer. 3 | 4 | 'HardCamlWaveTerm.Sim.Make(B).wrap' hooks us into the simulation and 5 | records the waveform data. 6 | 7 | The standard HardCaml Cs.reset and Cs.cycle calls are simply wrapped with 8 | Lwt.wrap1, then the testbench written in an (imperative) Lwt style. 9 | 10 | Lastly we use the HardCamlWaveTerm.Ui.run_testbench function with our 11 | testbench thread. In the code cycles are slowed down with a sleep call 12 | so we can watch them get dynamically generated in the viewer! *) 13 | 14 | open HardCaml.Api 15 | open Comb 16 | 17 | open HardCamlWaveTerm 18 | module W = Wave.Make(Wave.Bits(B)) 19 | module Ws = Sim.Make(B)(W) 20 | module R = Render.Static(W) 21 | 22 | module Ui = HardCamlWaveTerm.Ui.Make(B)(W) 23 | 24 | module I = struct 25 | type 'a t = { 26 | a : 'a [@bits 4]; 27 | b : 'a [@bits 4]; 28 | }[@@deriving hardcaml] 29 | end 30 | module O = struct 31 | type 'a t = { 32 | c : 'a [@bits 4]; 33 | }[@@deriving hardcaml] 34 | end 35 | 36 | open I 37 | open O 38 | 39 | let f i = 40 | { c = i.a +: i.b } 41 | 42 | module G = Interface.Gen(I)(O) 43 | 44 | let circ,sim,i,o,_ = G.make "test" f 45 | let sim, waves = Ws.wrap sim 46 | 47 | (* wrap reset and cycle functions in Lwt *) 48 | let reset sim = Lwt.wrap1 Cs.reset sim 49 | let cycle sim = let%lwt () = Lwt.wrap1 Cs.cycle sim in Lwt_unix.sleep 0.1 50 | 51 | let testbench () = 52 | let%lwt () = reset sim in 53 | for%lwt l=0 to 7 do 54 | for%lwt m=0 to 7 do 55 | i.a := B.consti 4 l; 56 | i.b := B.consti 4 m; 57 | let%lwt () = cycle sim in 58 | Lwt.return () 59 | done; 60 | done 61 | 62 | let waves = W.{ cfg={default with wave_width=(-1)}; waves } 63 | 64 | let%lwt () = 65 | match%lwt Ui.run_testbench ~timeout:0.5 waves (testbench()) with 66 | | None -> Lwt_io.printf "Canceled!\n" 67 | | Some(x) -> Lwt_io.printf "OK!\n" 68 | 69 | -------------------------------------------------------------------------------- /test/testwidget.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open LTerm_widget 3 | 4 | module B = HardCaml.Bits.Comb.IntbitsList 5 | module W = HardCamlWaveTerm.Wave.Make(HardCamlWaveTerm.Wave.Bits(B)) 6 | module Widget = HardCamlWaveTerm.Widget.Make(B)(W) 7 | 8 | let main () = 9 | let waiter, wakener = wait () in 10 | 11 | let get_waves name = 12 | let f = open_in name in 13 | let w = W.read f in 14 | close_in f; 15 | w 16 | in 17 | let waves = get_waves Sys.argv.(1) in 18 | 19 | let vbox = new vbox in 20 | let waveform = new Widget.waveform () in 21 | waveform#set_waves waves; 22 | vbox#add waveform; 23 | 24 | (* add status window *) 25 | let status = new Widget.status in 26 | status#set_waves waves; 27 | let frame = new HardCamlWaveTerm.LTerm_waveterm_compat.Frame.frame in 28 | frame#set status; 29 | frame#set_label "Status"; 30 | vbox#add ~expand:false frame; 31 | 32 | (* debug *) 33 | let debug_label = new label "foo" in 34 | ignore (Lwt_engine.on_timer 0.1 true (fun _ -> debug_label#set_text @@ 35 | Printf.sprintf "scroll [%i/%i] window [%ix%i] doc=[%ix%i] page=[%ix%i]" 36 | waveform#waves#vscroll#offset waveform#waves#vscroll#range 37 | LTerm_geom.((size_of_rect waveform#waves#allocation).rows) 38 | LTerm_geom.((size_of_rect waveform#waves#allocation).cols) 39 | waveform#waves#document_size.LTerm_geom.rows 40 | waveform#waves#document_size.LTerm_geom.cols 41 | waveform#waves#page_size.LTerm_geom.rows 42 | waveform#waves#page_size.LTerm_geom.cols 43 | )); 44 | 45 | vbox#add ~expand:false debug_label; 46 | 47 | let button = new button "exit" in 48 | button#on_click (wakeup wakener); 49 | vbox#add ~expand:false button; 50 | 51 | Widget.run_widget ~exit:(waiter,wakener) vbox 52 | 53 | let () = Lwt_main.run (main ()) 54 | 55 | -------------------------------------------------------------------------------- /test/testwidget_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | open HardCaml.Api 4 | 5 | module W = HardCamlWaveTerm.Wave.Make(HardCamlWaveTerm.Wave.Bits(B)) 6 | module Ws = HardCamlWaveTerm.Sim.Make(B)(W) 7 | 8 | module Widget = HardCamlWaveTerm.Widget.Make(B)(W) 9 | let waveform = new Widget.waveform () 10 | 11 | (* simple hardware design *) 12 | 13 | let bits = 8 14 | module I = struct 15 | type 'a t = { 16 | a : 'a [@bits bits]; 17 | b : 'a [@bits bits]; 18 | }[@@deriving hardcaml] 19 | end 20 | module O = struct 21 | type 'a t = { 22 | c : 'a [@bits bits]; 23 | }[@@deriving hardcaml] 24 | end 25 | 26 | open I 27 | open O 28 | 29 | let f i = Comb.{ c = i.a +: i.b } 30 | 31 | module G = Interface.Gen(I)(O) 32 | 33 | (* simulation *) 34 | 35 | let circ,sim,i,o,_ = G.make "test" f 36 | let sim, waves = Ws.wrap sim 37 | 38 | let reset sim = Lwt.wrap1 Cs.reset sim 39 | let cycle sim = 40 | let%lwt () = Lwt.wrap1 Cs.cycle sim in 41 | Lwt_unix.sleep 0.01 42 | 43 | let testbench () = 44 | let%lwt () = reset sim in 45 | let%lwt () = 46 | for%lwt l=0 to (1 lsl bits)-1 do 47 | for%lwt m=0 to (1 lsl bits)-1 do 48 | i.a := B.consti bits l; 49 | i.b := B.consti bits m; 50 | let%lwt () = cycle sim in 51 | Lwt.return () 52 | done; 53 | done 54 | in 55 | Lwt.return "ok" 56 | 57 | let rec update_loop () = 58 | waveform#update_wave_cycles; waveform#queue_draw; 59 | Lwt_unix.sleep 0.25 >> update_loop () 60 | 61 | (* waveform *) 62 | 63 | let main () = 64 | let waves = W.{ cfg={default with wave_width=(-1)}; waves } in 65 | waveform#set_waves waves; 66 | let run = 67 | let%lwt r = testbench () and () = update_loop () in 68 | Lwt.return r 69 | in 70 | Widget.run_widget_testbench waveform run 71 | 72 | let () = 73 | match Lwt_main.run (main ()) with 74 | | Some(s) -> Printf.eprintf "OK: %s\n%!" s 75 | | None -> Printf.eprintf "QUIT\n%!" (* why doesnt this print? *) 76 | 77 | let () = Printf.eprintf "OVER.\n%!" 78 | 79 | -------------------------------------------------------------------------------- /test/toggle.wave: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ujamjar/hardcaml-waveterm/8f1be28f22d0d98cc6c4424ef55b79a873e93c3c/test/toggle.wave -------------------------------------------------------------------------------- /test/wave-static.html: -------------------------------------------------------------------------------- 1 | 
 2 | ┌Signals─┐┌Values──┐┌Waves─────────────────────────────────────────────────────┐
 3 | │clock   ││        ││┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌─│
 4 | │        ││        ││    └───┘   └───┘   └───┘   └───┘   └───┘   └───┘   └───┘ │
 5 | │a       ││0       ││                ┌───────┐       ┌───────┐               ┌─│
 6 | │        ││        ││────────────────┘       └───────┘       └───────────────┘ │
 7 | │        ││        ││────────┬───────┬───────┬───────┬───────┬───────┬───────┬─│
 8 | │b       ││-318    ││ -318   │-131   │387    │-33    │-69    │-5     │-463   │3│
 9 | │        ││        ││────────┴───────┴───────┴───────┴───────┴───────┴───────┴─│
10 | │c       ││0       ││                ┌───────────────┐                       ┌─│
11 | │        ││        ││────────────────┘               └───────────────────────┘ │
12 | │        ││        ││────────────────┬───────┬───────┬───────┬───────┬───────┬─│
13 | │gamma-om││1       ││ 1              │9      │8      │4      │6      │5      │0│
14 | │        ││        ││────────────────┴───────┴───────┴───────┴───────┴───────┴─│
15 | │        ││        ││────────┬───────┬───────┬───────────────────────────────┬─│
16 | │beta    ││0       ││ 0      │2      │1      │0                              │2│
17 | │        ││        ││────────┴───────┴───────┴───────────────────────────────┴─│
18 | │delta   ││1       ││────────┐       ┌───────┐       ┌───────┐       ┌───────┐ │
19 | │        ││        ││        └───────┘       └───────┘       └───────┘       └─│
20 | │eye     ││0       ││        ┌───────┐                               ┌─────────│
21 | │        ││        ││────────┘       └───────────────────────────────┘         │
22 | │        ││        ││────────┬───────┬───────┬───────┬───────┬───────────────┬─│
23 | │enable  ││1       ││ 1      │-4     │-1     │3      │1      │-4             │-│
24 | │        ││        ││────────┴───────┴───────┴───────┴───────┴───────────────┴─│
25 | │clock2  ││        ││┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌───┐   ┌─│
26 | │        ││        ││    └───┘   └───┘   └───┘   └───┘   └───┘   └───┘   └───┘ │
27 | │        ││        ││────────┬───────┬───────┬───────┬───────────────┬───────┬─│
28 | │bubble  ││-2      ││ -2     │8      │-6     │1      │-1             │6      │-│
29 | │        ││        ││────────┴───────┴───────┴───────┴───────────────┴───────┴─│
30 | │fairy   ││0       ││        ┌───────┐       ┌───────────────┐                 │
31 | │        ││        ││────────┘       └───────┘               └─────────────────│
32 | └────────┘└────────┘└──────────────────────────────────────────────────────────┘
33 |
-------------------------------------------------------------------------------- /test/wave.txt: -------------------------------------------------------------------------------- 1 | ┌Signals─┐┌Values──┐┌Waves───────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┐ 2 | │clock ││ ││┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───│ 3 | │ ││ ││ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ │ 4 | │a ││0 ││ ┌───────┐ ┌───────┐ ┌───────────────────────────────────────┐ ┌───────┐ ┌───────────────────│ 5 | │ ││ ││────────────────┘ └───────┘ └───────────────┘ └───────────────┘ └───────┘ │ 6 | │ ││ ││────────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───│ 7 | │b ││-318 ││ -318 │-131 │387 │-33 │-69 │-5 │-463 │336 │326 │204 │-366 │479 │77 │-22 │381 │-330 │418 │-80 │57 │ 8 | │ ││ ││────────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───│ 9 | │c ││0 ││ ┌───────────────┐ ┌───────┐ ┌───────┐ ┌───────────────┐ ┌───────────────┐ │ 10 | │ ││ ││────────────────┘ └───────────────────────┘ └───────┘ └───────────────────────┘ └───────┘ └───│ 11 | │ ││ ││────────────────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───│ 12 | │gamma-om││1 ││ 1 │9 │8 │4 │6 │5 │0 │2 │5 │1 │9 │7 │4 │1 │8 │7 │1 │8 │ 13 | │ ││ ││────────────────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───│ 14 | │ ││ ││────────┬───────┬───────┬───────────────────────────────┬───────┬───────────────┬───────────────┬───────┬───────┬───────┬───────────────┬───────┬───│ 15 | │beta ││0 ││ 0 │2 │1 │0 │2 │1 │2 │1 │0 │1 │2 │0 │1 │ 16 | │ ││ ││────────┴───────┴───────┴───────────────────────────────┴───────┴───────────────┴───────────────┴───────┴───────┴───────┴───────────────┴───────┴───│ 17 | │delta ││1 ││────────┐ ┌───────┐ ┌───────┐ ┌───────┐ ┌───────────────┐ ┌───────┐ │ 18 | │ ││ ││ └───────┘ └───────┘ └───────┘ └───────────────┘ └───────────────┘ └───────────────────────────────────│ 19 | │eye ││0 ││ ┌───────┐ ┌───────────────┐ ┌───────────────────────┐ ┌───────────────────────────│ 20 | │ ││ ││────────┘ └───────────────────────────────┘ └───────────────────────┘ └───────┘ │ 21 | │ ││ ││────────┬───────┬───────┬───────┬───────┬───────────────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───│ 22 | │enable ││1 ││ 1 │-4 │-1 │3 │1 │-4 │-3 │0 │4 │-4 │-5 │4 │3 │-3 │-2 │-4 │1 │4 │ 23 | │ ││ ││────────┴───────┴───────┴───────┴───────┴───────────────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───│ 24 | │clock2 ││ ││┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───┐ ┌───│ 25 | │ ││ ││ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ └───┘ │ 26 | │ ││ ││────────┬───────┬───────┬───────┬───────────────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┬───│ 27 | │bubble ││-2 ││ -2 │8 │-6 │1 │-1 │6 │-4 │8 │-8 │-5 │2 │9 │-7 │-8 │-10 │0 │5 │6 │ 28 | │ ││ ││────────┴───────┴───────┴───────┴───────────────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┴───│ 29 | │fairy ││0 ││ ┌───────┐ ┌───────────────┐ ┌───────┐ ┌───────────────────────┐ ┌───────┐ ┌───────┐ │ 30 | │ ││ ││────────┘ └───────┘ └───────────────────────┘ └───────┘ └───────┘ └───────┘ └───────────│ 31 | └────────┘└────────┘└────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┘ 32 | --------------------------------------------------------------------------------