stitch

Note taking for messy minimalists

git clone git://mccd.space/stitch

common.ml (4237B)

      1 (* Copyright (c) 2016-2017 David Kaloper Meršinjak. All rights reserved.
      2    See https://github.com/pqwy/notty/blob/master/LICENSE.md *)
      3 
      4 open Notty
      5 open Notty.Infix
      6 
      7 let pow n e = int_of_float (float n ** float e)
      8 
      9 module List = struct
     10   include List
     11 
     12   let rec replicate n a = if n < 1 then [] else a :: replicate (n - 1) a
     13   let rec range a b = if a > b then [] else a :: range (a + 1) b
     14 
     15   let rec intersperse a = function
     16     | ([] | [ _ ]) as t -> t
     17     | x :: xs -> x :: a :: intersperse a xs
     18 
     19 
     20   let rec take n = function
     21     | x :: xs when n > 0 -> x :: take (pred n) xs
     22     | _ -> []
     23 
     24 
     25   let rec splitat n = function
     26     | x :: xs when n > 0 ->
     27       let a, b = splitat (pred n) xs in
     28       x :: a, b
     29     | xs -> [], xs
     30 
     31 
     32   let rec chunks n xs =
     33     match splitat n xs with
     34     | a, [] -> [ a ]
     35     | a, b -> a :: chunks n b
     36 
     37 
     38   let rec zip xs ys =
     39     match xs, ys with
     40     | [], _ | _, [] -> []
     41     | x :: xs, y :: ys -> (x, y) :: zip xs ys
     42 end
     43 
     44 module String = struct
     45   include String
     46 
     47   let repeat n str =
     48     let b = Buffer.create 16 in
     49     for _ = 1 to n do
     50       Buffer.add_string b str
     51     done;
     52     Buffer.contents b
     53 end
     54 
     55 let tile w h i = I.tabulate w h (fun _ _ -> i)
     56 
     57 (** A few images used in several places. *)
     58 module Images = struct
     59   let i1 =
     60     I.(string A.(fg lightblack) "omgbbq" <-> string A.(fg white ++ bg red) "@")
     61     <|> I.(pad ~t:2 @@ string A.(fg green) "xo")
     62 
     63 
     64   let i2 = I.(hpad 1 1 (hcrop 1 1 @@ tile 3 3 i1) <|> i1)
     65   let i3 = tile 5 5 i2
     66 
     67   let i4 =
     68     let i = I.(i3 <|> crop ~t:1 i3 <|> i3) in
     69     I.(crop ~l:1 i <-> crop ~r:1 i <-> crop ~b:2 i)
     70 
     71 
     72   let i5 = tile 5 1 List.(range 0 15 |> map (fun i -> I.pad ~t:i ~l:(i * 2) i2) |> I.zcat)
     73   let c_gray_ramp = I.tabulate 24 1 (fun g _ -> I.string A.(bg (gray g)) " ")
     74 
     75   let c_cube_ix =
     76     I.tabulate 6 1
     77     @@ fun r _ ->
     78     I.hpad 0 1 @@ I.tabulate 6 6 @@ fun b g -> I.string A.(bg (rgb ~r ~g ~b)) " "
     79 
     80 
     81   let c_cube_rgb =
     82     let f x = [| 0x00; 0x5f; 0x87; 0xaf; 0xd7; 0xff |].(x) in
     83     I.tabulate 6 1
     84     @@ fun r _ ->
     85     I.hpad 0 1
     86     @@ I.tabulate 6 6
     87     @@ fun b g -> I.string A.(bg (rgb_888 ~r:(f r) ~g:(f g) ~b:(f b))) " "
     88 
     89 
     90   let c_rainbow w h =
     91     let pi2 = 2. *. 3.14159 in
     92     let pi2_3 = pi2 /. 3.
     93     and f t off = (sin (t +. off) *. 128.) +. 128. |> truncate in
     94     let color t = A.rgb_888 ~r:(f t (-.pi2_3)) ~g:(f t 0.) ~b:(f t pi2_3) in
     95     I.tabulate (w - 1) 1
     96     @@ fun x _ ->
     97     let t = (pi2 *. float x /. float w) +. 3.7 in
     98     I.char A.(bg (color t)) ' ' 1 h
     99 
    100 
    101   (* U+25CF BLACK CIRCLE *)
    102   let dot color = I.string (A.fg color) "●"
    103 
    104   (* U+25AA BLACK SMALL SQUARE *)
    105   let square color = I.string (A.fg color) "▪"
    106 
    107   let rec cantor = function
    108     | 0 -> square A.lightblue
    109     | n ->
    110       let sub = cantor (pred n) in
    111       I.hcat (List.replicate (pow 3 n) (square A.lightblue))
    112       <-> (sub <|> I.void (pow 3 (n - 1)) 0 <|> sub)
    113 
    114 
    115   let checker n m i =
    116     let w = I.width i in
    117     I.(tile (n / 2) (m / 2) (hpad 0 w i <-> hpad w 0 i))
    118 
    119 
    120   let checker1 = checker 20 20 I.(char A.(bg magenta) ' ' 2 1)
    121 
    122   let rec sierp c n =
    123     I.(
    124       if n > 1
    125       then (
    126         let ss = sierp c (pred n) in
    127         ss <-> (ss <|> ss))
    128       else hpad 1 0 (square c))
    129 
    130 
    131   let grid xxs = xxs |> List.map I.hcat |> I.vcat
    132 
    133   let outline attr i =
    134     let w, h = I.(width i, height i) in
    135     let chr x = I.uchar attr (Uchar.of_int x) 1 1
    136     and hbar = I.uchar attr (Uchar.of_int 0x2500) w 1
    137     and vbar = I.uchar attr (Uchar.of_int 0x2502) 1 h in
    138     let a, b, c, d = chr 0x256d, chr 0x256e, chr 0x256f, chr 0x2570 in
    139     grid [ [ a; hbar; b ]; [ vbar; i; vbar ]; [ d; hbar; c ] ]
    140 end
    141 
    142 let halfblock = "▄"
    143 
    144 let pxmatrix w h f =
    145   I.tabulate w h
    146   @@ fun x y ->
    147   let y = y * 2 in
    148   I.string A.(bg (f x y) ++ fg (f x (y + 1))) halfblock
    149 
    150 
    151 module Term = Notty_unix.Term
    152 
    153 let simpleterm ~imgf ~f ~s =
    154   let term = Term.create () in
    155   let imgf (w, h) s = I.(string A.(fg lightblack) "[ESC quits.]" <-> imgf (w, h - 1) s) in
    156   let rec go s =
    157     Term.image term (imgf (Term.size term) s);
    158     match Term.event term with
    159     | `End | `Key (`Escape, []) | `Key (`ASCII 'C', [ `Ctrl ]) -> ()
    160     | `Resize _ -> go s
    161     | #Unescape.event as e ->
    162       (match f s e with
    163        | Some s -> go s
    164        | _ -> ())
    165   in
    166   go s