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 math sequences sequences.private ;
   5 IN: wrap
   6
   7 TUPLE: element contents black white ;
   8
   9 C: <element> element
  10
  11 :: wrap ( elements width -- array )
  12     elements length integer>fixnum-strict :> #elements
  13     elements [ black>> ] { } map-as :> black
  14     elements [ white>> ] { } map-as :> white
  15
  16     #elements 1 + f <array> :> minima
  17     #elements 1 + 0 <array> :> breaks
  18
  19     0 0 minima set-nth-unsafe
  20
  21     minima [| base i |
  22         0 i 1 + [ dup #elements <= ] [| j |
  23             j 1 - black nth-unsafe + dup :> w
  24             j 1 - white nth-unsafe +
  25
  26             w width > [
  27                 j 1 - i = [
  28                     0 j minima set-nth-unsafe
  29                     i j breaks set-nth-unsafe
  30                 ] when #elements
  31             ] [
  32                 base
  33                 j #elements = [ width w - sq + ] unless :> cost
  34                 j minima nth-unsafe [ cost >= ] [ t ] if* [
  35                     cost j minima set-nth-unsafe
  36                     i j breaks set-nth-unsafe
  37                 ] when j
  38             ] if 1 +
  39         ] while 2drop
  40     ] each-index
  41
  42     #elements [ dup 0 > ] [
  43         [ breaks nth dup ] keep elements <slice>
  44         [ contents>> ] map
  45     ] produce nip reverse ;