diff options
Diffstat (limited to '')
| l--------- | bin/.#main.ml | 1 | ||||
| -rw-r--r-- | bin/common.ml | 166 | ||||
| -rw-r--r-- | bin/dune | 12 | ||||
| -rw-r--r-- | bin/main.ml | 77 |
4 files changed, 256 insertions, 0 deletions
diff --git a/bin/.#main.ml b/bin/.#main.ml new file mode 120000 index 0000000..5a91e42 --- /dev/null +++ b/bin/.#main.ml @@ -0,0 +1 @@ +mccd@void.21115:1715189760
\ No newline at end of file diff --git a/bin/common.ml b/bin/common.ml new file mode 100644 index 0000000..adfeee6 --- /dev/null +++ b/bin/common.ml @@ -0,0 +1,166 @@ +(* Copyright (c) 2016-2017 David Kaloper Meršinjak. All rights reserved. + See LICENSE.md. *) + +open Notty +open Notty.Infix + +let pow n e = int_of_float (float n ** float e) + +module List = struct + include List + + let rec replicate n a = if n < 1 then [] else a :: replicate (n - 1) a + let rec range a b = if a > b then [] else a :: range (a + 1) b + + let rec intersperse a = function + | ([] | [ _ ]) as t -> t + | x :: xs -> x :: a :: intersperse a xs + + + let rec take n = function + | x :: xs when n > 0 -> x :: take (pred n) xs + | _ -> [] + + + let rec splitat n = function + | x :: xs when n > 0 -> + let a, b = splitat (pred n) xs in + x :: a, b + | xs -> [], xs + + + let rec chunks n xs = + match splitat n xs with + | a, [] -> [ a ] + | a, b -> a :: chunks n b + + + let rec zip xs ys = + match xs, ys with + | [], _ | _, [] -> [] + | x :: xs, y :: ys -> (x, y) :: zip xs ys +end + +module String = struct + include String + + let repeat n str = + let b = Buffer.create 16 in + for _ = 1 to n do + Buffer.add_string b str + done; + Buffer.contents b +end + +let tile w h i = I.tabulate w h (fun _ _ -> i) + +(** A few images used in several places. *) +module Images = struct + let i1 = + I.(string A.(fg lightblack) "omgbbq" <-> string A.(fg white ++ bg red) "@") + <|> I.(pad ~t:2 @@ string A.(fg green) "xo") + + + let i2 = I.(hpad 1 1 (hcrop 1 1 @@ tile 3 3 i1) <|> i1) + let i3 = tile 5 5 i2 + + let i4 = + let i = I.(i3 <|> crop ~t:1 i3 <|> i3) in + I.(crop ~l:1 i <-> crop ~r:1 i <-> crop ~b:2 i) + + + let i5 = tile 5 1 List.(range 0 15 |> map (fun i -> I.pad ~t:i ~l:(i * 2) i2) |> I.zcat) + let c_gray_ramp = I.tabulate 24 1 (fun g _ -> I.string A.(bg (gray g)) " ") + + let c_cube_ix = + I.tabulate 6 1 + @@ fun r _ -> + I.hpad 0 1 @@ I.tabulate 6 6 @@ fun b g -> I.string A.(bg (rgb ~r ~g ~b)) " " + + + let c_cube_rgb = + let f x = [| 0x00; 0x5f; 0x87; 0xaf; 0xd7; 0xff |].(x) in + I.tabulate 6 1 + @@ fun r _ -> + I.hpad 0 1 + @@ I.tabulate 6 6 + @@ fun b g -> I.string A.(bg (rgb_888 ~r:(f r) ~g:(f g) ~b:(f b))) " " + + + let c_rainbow w h = + let pi2 = 2. *. 3.14159 in + let pi2_3 = pi2 /. 3. + and f t off = (sin (t +. off) *. 128.) +. 128. |> truncate in + let color t = A.rgb_888 ~r:(f t (-.pi2_3)) ~g:(f t 0.) ~b:(f t pi2_3) in + I.tabulate (w - 1) 1 + @@ fun x _ -> + let t = (pi2 *. float x /. float w) +. 3.7 in + I.char A.(bg (color t)) ' ' 1 h + + + (* U+25CF BLACK CIRCLE *) + let dot color = I.string (A.fg color) "●" + + (* U+25AA BLACK SMALL SQUARE *) + let square color = I.string (A.fg color) "▪" + + let rec cantor = function + | 0 -> square A.lightblue + | n -> + let sub = cantor (pred n) in + I.hcat (List.replicate (pow 3 n) (square A.lightblue)) + <-> (sub <|> I.void (pow 3 (n - 1)) 0 <|> sub) + + + let checker n m i = + let w = I.width i in + I.(tile (n / 2) (m / 2) (hpad 0 w i <-> hpad w 0 i)) + + + let checker1 = checker 20 20 I.(char A.(bg magenta) ' ' 2 1) + + let rec sierp c n = + I.( + if n > 1 + then ( + let ss = sierp c (pred n) in + ss <-> (ss <|> ss)) + else hpad 1 0 (square c)) + + + let grid xxs = xxs |> List.map I.hcat |> I.vcat + + let outline attr i = + let w, h = I.(width i, height i) in + let chr x = I.uchar attr (Uchar.of_int x) 1 1 + and hbar = I.uchar attr (Uchar.of_int 0x2500) w 1 + and vbar = I.uchar attr (Uchar.of_int 0x2502) 1 h in + let a, b, c, d = chr 0x256d, chr 0x256e, chr 0x256f, chr 0x2570 in + grid [ [ a; hbar; b ]; [ vbar; i; vbar ]; [ d; hbar; c ] ] +end + +let halfblock = "▄" + +let pxmatrix w h f = + I.tabulate w h + @@ fun x y -> + let y = y * 2 in + I.string A.(bg (f x y) ++ fg (f x (y + 1))) halfblock + + +module Term = Notty_unix.Term + +let simpleterm ~imgf ~f ~s = + let term = Term.create () in + let imgf (w, h) s = I.(string A.(fg lightblack) "[ESC quits.]" <-> imgf (w, h - 1) s) in + let rec go s = + Term.image term (imgf (Term.size term) s); + match Term.event term with + | `End | `Key (`Escape, []) | `Key (`ASCII 'C', [ `Ctrl ]) -> () + | `Resize _ -> go s + | #Unescape.event as e -> + (match f s e with + | Some s -> go s + | _ -> ()) + in + go s diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..962b989 --- /dev/null +++ b/bin/dune @@ -0,0 +1,12 @@ +(executable + (public_name stitch) + (name main) + (libraries + stitch + unix + cmdliner + str + notty + notty.unix + shexp.process + lambda-term)) diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..404c63e --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,77 @@ +open Notty +open Common + +let content = Stitch.get_headlines () |> Stitch.parse_headlines +let content_pretty = content |> Stitch.pretty_format + +let rec main t (((x, y) as pos), scroll) = + let img = + let dot = I.string A.(fg black) ">" |> I.pad ~l:0 ~t:(y - scroll) + and elements = + Array.mapi + (fun i el -> I.strf ~attr:A.(fg black) "%s" el |> I.pad ~l:2 ~t:i) + (Array.to_seq content_pretty |> Seq.drop scroll |> Array.of_seq) + in + let open I in + Array.fold_left (fun sum el -> el </> sum) dot elements + in + let _, size_y = Term.size t in + Term.image t img; + let content_length = Array.length content_pretty in + let scroll_up () = + let scroll = if y - scroll = 0 then max (scroll - 1) 0 else scroll in + main t @@ ((x, max (y - 1) 0), scroll) + in + let scroll_down () = + let scroll = if y - scroll >= size_y - 1 then scroll + 1 else scroll in + main t @@ ((x, min (y + 1) content_length), scroll) + in + match Term.event t with + | `End | `Key (`Escape, []) | `Key (`ASCII 'q', []) | `Key (`ASCII 'C', [ `Ctrl ]) -> () + | `Mouse (`Press (`Scroll s), _, _) -> + (match s with + | `Down -> scroll_down () + | `Up -> scroll_up ()) + | `Resize _ -> main t (pos, scroll) + | `Mouse ((`Press _ | `Drag), (_, y), _) -> main t ((0, min y content_length), scroll) + | `Key (`ASCII 'j', []) | `Key (`ASCII 'N', [ `Ctrl ]) -> scroll_down () + | `Key (`ASCII 'k', []) | `Key (`ASCII 'P', [ `Ctrl ]) -> + let scroll = if y - scroll = 0 then max (scroll - 1) 0 else scroll in + main t @@ ((x, max (y - 1) 0), scroll) + | `Key (`Arrow d, _) -> + (match d with + | `Up -> scroll_up () + | `Down -> scroll_down () + | _ -> main t ((x, y), scroll)) + | `Key (`ASCII 'e', []) | `Key (`Enter, []) -> + (* Editor might be set with extra args, in that case we need to separate these *) + let[@warning "-8"] (editor :: args) = + String.split_on_char ' ' (Sys.getenv "EDITOR") + in + let selected_file, _ = Array.get content y in + let full_path_file = Stitch.execution_directory ^ "/" ^ selected_file in + let full_args = Array.append (Array.of_list args) [| full_path_file |] in + Term.cursor t (Some (0, 0)); + let _ = + Unix.create_process_env + editor + full_args + (Unix.environment ()) + Unix.stdin + Unix.stdout + Unix.stderr + in + let rec run_editor () = + match Unix.wait () with + | _, _ -> + Term.cursor t None; + main t ((x, y), scroll) + (* Capture resizing events *) + | exception Unix.Unix_error (Unix.EINTR, _, _) -> run_editor () + | exception Unix.Unix_error (_, _, _) -> failwith "ERROR" + in + run_editor () + | _ -> main t (pos, scroll) + + +let () = main (Term.create ()) ((0, 0), 0) |