basis/wrap/wrap.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! Copyright (C) 2017 John Benediktsson
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays kernel locals math sequences
   5 sequences.private ;
   6 IN: wrap
   7
   8 TUPLE: element contents black white ;
   9
  10 C: <element> element
  11
  12 :: wrap ( elements width -- array )
  13     elements length integer>fixnum-strict :> #elements
  14     elements [ black>> ] { } map-as :> black
  15     elements [ white>> ] { } map-as :> white
  16
  17     #elements 1 + f <array> :> minima
  18     #elements 1 + 0 <array> :> breaks
  19
  20     0 0 minima set-nth-unsafe
  21
  22     minima [| base i |
  23         0 i 1 + [ dup #elements <= ] [| j |
  24             j 1 - black nth-unsafe + dup :> w
  25             j 1 - white nth-unsafe +
  26
  27             w width > [
  28                 j 1 - i = [
  29                     0 j minima set-nth-unsafe
  30                     i j breaks set-nth-unsafe
  31                 ] when #elements
  32             ] [
  33                 base
  34                 j #elements = [ width w - sq + ] unless :> cost
  35                 j minima nth-unsafe [ cost >= ] [ t ] if* [
  36                     cost j minima set-nth-unsafe
  37                     i j breaks set-nth-unsafe
  38                 ] when j
  39             ] if 1 +
  40         ] while 2drop
  41     ] each-index
  42
  43     #elements [ dup 0 > ] [
  44         [ breaks nth dup ] keep elements <slice>
  45         [ contents>> ] map
  46     ] produce nip reverse ;