(relacionado: uno , dos , tres )

Un acróstico es un estilo de poema / escritura donde el carácter inicial de cada línea, cuando se lee verticalmente, también produce una palabra o mensaje. Por ejemplo,

Together
Everyone
Achieves
More

también deletrea la palabra TEAM cuando la primera columna se lee verticalmente.

Los acrósticos son un subconjunto de s mesosticos , donde la palabra vertical puede estar en cualquier lugar de las palabras horizontales. Por ejemplo, el TEAManterior también podría escribirse como un mesostico de la siguiente manera

   togeTher
everyonE
       Achieves
       More

junto con varias otras variaciones.

El desafío aquí será producir un acróstico o mesostico a partir de una lista dada de palabras de entrada.

Entrada

• Una lista de palabras en cualquier formato adecuado .
• La lista solo contendrá palabras en minúsculas [a-z] .
• Se garantiza que la lista formará un acróstico o un mesostico (no es necesario manejar entradas falsas).
• Una de las palabras en la entrada formará la palabra vertical, mientras que el resto hace las palabras horizontales; parte del desafío aquí es encontrar la palabra vertical adecuada, para que no se pueda tomar por separado.

Salida

• El acróstico o mesostico del arte ASCII formado a partir de las palabras de entrada, escritas a STDOUT o devueltas, en cualquier formato razonable.
• La palabra vertical correspondiente debe estar en mayúscula (como en los ejemplos).
• Se requieren espacios iniciales para que la palabra vertical se alinee adecuadamente . Los espacios finales y las nuevas líneas iniciales / finales son opcionales. Los espacios iniciales adicionales también están bien, siempre que las palabras se alineen correctamente.
• Si ambos son posibles un acróstico y mesostic, salida única el acróstico.
• Si es posible más de un acróstico / mesostico, su código puede generar uno o todos ellos.

Reglas

• Un programa completo o una función son aceptables.
• Las lagunas estándar están prohibidas.
• Este es el código de golf, por lo que se aplican todas las reglas habituales de golf, y gana el código más corto (en bytes).

Ejemplos

['together', 'team', 'everyone', 'achieves', 'more']
Together
Everyone
Achieves
More

['aaa', 'aaa', 'aaa', 'aaa']
Aaa
Aaa
Aaa
# One output, or multiple (of the same) output is allowed

['aaa', 'aaa', 'aab', 'baa']
Aaa
Aaa
Baa
# This is the only allowed output, since others would be mesostic, which are lower priority

['live', 'every', 'love', 'very', 'ohio']
Live
Ohio
Very
Every
# Note that 'live' couldn't be the vertical word since then it would be a mesostic, which is lower priority output

['cow', 'of', 'fox']
cOw
 Fox
# A shorter mesostic test case

['late', 'ballroom', 'anvil', 'to', 'head']
anviL
   bAllroom
    To
   hEad

Pyth, 52 49 47 46 bytes

jm++*;-lsQhAd<HGr>HG4hhMDfhhShMTm.b,xNYNtdhd.p

Pruébalo en línea.

Esto es probablemente muy golfable. Imprime un montón de espacios principales.

Brachylog , 145 bytes

p~c[A:B:C],Bl1,A:CcP@pz:cahgB,P:1a~@nw|lL,?:laot:" "rjg:Ljb:sa:?z:cap~c[A:B:C],Bl1,A:Cc@pz:caZ:LmgB,Zl-yM,Z:M:Lz:2az:ca~@nw
bB,?h@u:Bc
b#=,?h@u|h

Pruébalo en línea!

(Toma medio minuto, así que sea paciente).

JavaScript (ES6), 255 263 269 286

Editar 17 bytes guardados ya que se permite un número arbitrario de espacios
iniciales Editar2 algunos barajados, 6 bytes guardados
Editar3 devolver una lista de cadenas en lugar de una sola cadena con nuevas líneas (comentario OP a la respuesta del feersum), 8 bytes más guardados

Para cada palabra en la lista de entrada, uso un DFS recursivo para encontrar todos los mesosticos / acrósticos posibles. Cada uno se almacena como una matriz con la palabra y la posición de la letra de destino dentro de la palabra. Cada resultado encontrado se guarda en la matriz de resultados global en la posición 1 (si es un acróstico) o 0 si es un mesostico.

Después del escaneo completo de todas las palabras, obtengo el resultado en la última posición en conjunto y construyo y devuelvo su representación de arte ascii.

l=>(l.map((w,i)=>(r=(p,v,i,a)=>(l[i]='.',w[p]?l.map((v,i)=>~(j=v.search(w[p]))&&r(p+1,v,i,a|j,m[p]=[j,v])):l[p+1]?0:s[+!a]=[...m],l[i]=v))(0,w,i,m=[]),s=[]),m=s.pop(),m.map(([j,v])=>' '.repeat((l+0).length-j)+v.slice(0,j)+v[j].toUpperCase()+v.slice(j+1)))

Menos golf

f=l=>(
  l.map((w,i)=>
    // r: recursive DFS function
    // defined here as it uses local w variable
    (r = (p,v,i,a) => (
     l[i] = '.'
     , w[p] 
     ? l.map(
       (v,i) => ~(j=v.search(w[p])) && 
                r(p+1, v, i, a|j, m[p] = [j,v])

     )
     : l[p+1] ? 0 // invalid if there are still unused words
              : s[+!a]=[...m] // a is 0 if acrostic
     , l[i] = v) 
    )(0, w, i, m=[])
  , s=[]),
  m = s.pop(), // get last result
  // m.map(([j]) => o = o<j ? j : o, o=0), // find offset for alignment
  // no need to find the optimal offset as leading blanks are allowed
  m.map(([j,v]) => ' '.repeat((l+0).length-j) 
                   + v.slice(0,j) 
                   + v[j].toUpperCase()
                   + v.slice(j+1)
  )
)

Prueba

f=l=>(l.map((w,i)=>(r=(p,v,i,a)=>(l[i]='.',w[p]?l.map((v,i)=>~(j=v.search(w[p]))&&r(p+1,v,i,a|j,m[p]=[j,v])):l[p+1]?0:s[+!a]=[...m],l[i]=v))(0,w,i,m=[]),s=[]),m=s.pop(),m.map(([j,v])=>' '.repeat((l+0).length-j)+v.slice(0,j)+v[j].toUpperCase()+v.slice(j+1)))

console.log=x=>O.textContent+=x+'\n\n'

;[
 ['together', 'team', 'everyone', 'achieves', 'more']
,['aaa', 'aaa', 'aaa', 'aaa']
,['aaa', 'aaa', 'aab', 'baa']
,['live', 'every', 'love', 'very', 'ohio']
,['cow', 'of', 'fox']
,['late', 'ballroom', 'anvil', 'to', 'head']
].forEach(l=>console.log(f(l).join`\n`))

<pre id=O></pre>

Perl6, 287 277 269 bytes

my @w=$*IN.words;my ($q,$r)=gather for ^@w {my @v=@w.rotate($_);my \d=@v.shift;for @v.permutations {my @o=flat($_ Z d.comb).map:{$^a.index: $^b};take $_,@o if @o>>.defined.all}}.sort(*[1].sum)[0];for @$q Z @$r ->(\a,\b){say " "x($r.max -b)~a.substr(0,b)~a.substr(b).tc}

Mathematica 10.0, 139 bytes

Una función sin nombre que devuelve una lista de líneas:

Sort[{q=Max[p=Min/@Position@@@({z={##2},#})],Array[" "&,q-#2]<>ToUpperCase~MapAt~##&@@@({z,p})}&@@@Permutations@Characters@#][[1,2]]&

Ejemplo de uso:

En [144]: = f = Ordenar [{q = Máx. [P = Mín. / @ Posición @@@ ({z = {## 2}, #} ​​)], Matriz ["" &, q- # 2 ] ToUpperCase ~ MapAt ~ ## & @@@ ({z, p} )} & @@@ Permutaciones @ Caracteres @ #] [[1,2]] &;

En [145]: = f @ {"tarde", "salón de baile", "yunque", "a", "cabeza"} // Columna

 ... varias páginas de advertencias ... 

Fuera [145] = baLlroom
            Yunque
            A
           cabeza

Estoy buscando sugerencias sobre mejores formas de capitalizar. Encontré una función muy agradable MapAtpara poner en mayúscula la letra en la cadena.

Haskell, 214 206 204 202 bytes

import Data.List
z=zipWith
h i j t|(u,v:w)<-splitAt j t=([1..sum i-j]>>" ")++u++toEnum(fromEnum v-32):w
f x=uncurry(z=<<h)$sort[(head<$>z elemIndices w l,l)|w:l<-permutations x,(True<$w)==z elem w l]!!0

Devuelve una lista de cadenas rellenas de espacio, por ejemplo, f ["late","ballroom","anvil","to","head"]-> [" baLlroom"," Anvil"," To"," hEad"]o más para mostrar:

*Main> mapM_ putStrLn $ f ["late", "ballroom", "anvil", "to", "head"]
 baLlroom
   Anvil
   To
  hEad

fselecciona las palabras que se escriben horizontalmente junto con una lista de desplazamientos. hrellena cada palabra de acuerdo con el desplazamiento correspondiente e inserta la letra mayúscula. En detalle:

                permutations x       -- for each permutation of the input list x
         w:l<-                       -- bind w to the first word and l to the rest
             (True<$w)==z elem w l   -- keep it if the list of other words
                                     -- containing the next letter of w
                                     -- equals (length w) times True, i.e. we have
                                     -- as many matching letters as letters in w.
                                     -- This rules out combinations shortcut by zipWith

                                     -- for all the remaining w and l make a pair
         head<$>z elemIndices w l    -- the first element of the list of list of
                                     -- indices where the letter appears in the word 
                                l    -- and l itself
   sort                              -- sort the pairs (all 0 indices, i.e. acrostics
                                     -- go first)
                               !!0   -- pick the first
                                     -- now we have a pair like
                                     -- ([2,0,0,1],["ballroom","anvil","to","head"])
 uncurry(z=<<h)                      -- loop over (index,word) and 
                                     -- provide the third parameter for h 



 h i j t                             -- h takes the list of indices and
                                     -- an index j and a word t
       (u,v:w)<-splitAt j t          -- split the word at the index and bind
                                     --   u: part before the split
                                     --   v: letter at the split
                                     --   w: part after the split
         [1..sum i-j]>>" "           -- the spaces to pad
           ++ u                      -- followed by u
           ++ toEnum(fromEnum v-32)  -- and uppercase v
           :                         -- and w 

Python, 249 bytes

Probablemente sigue siendo muy golfable

from itertools import*;e=enumerate;lambda l:[[[' ']*(max(j for k,(j,c)in o[1:])-i)+l[k][:i]+[c.upper()]+l[k][i+1:]for k,(i,c)in o[1:]]for p in product(*[list(e(w))for w in l])for o in permutations(list(e(p)))if[c for k,(i,c)in o[1:]]==l[o[0][0]]][0]

Toma y devuelve una lista de la lista de caracteres.
- por ejemplo " bAllroom"es[' ',' ',' ','b','A','l','l','r','o','o','m']

Solo devuelve el primer resultado y verifica en un orden tal que todos los acrósticos se verifiquen primero.

Vea todos los casos de prueba impresos en el formato de visualización en ideone

Aquí hay una forma funcional más legible que hace lo mismo (excepto que devuelve el primer resultado inmediatamente en lugar de evaluar y luego devolver el primer resultado):

from itertools import*
def f(l):
    for p in product(*[list(enumerate(w)) for w in l]):
        for o in permutations(list(enumerate(p))):
            if [c for k,(i,c) in o[1:]] == l[o[0][0]]:
                return [ [' '] * (max(j for k,(j,c) in o[1:]) - i)
                       + l[k][:i]
                       + [c.upper()]
                       + l[k][i+1:]
                       for k, (i, c) in o[1:]
                       ]

Perl 6, 177 bytes

->\a{for first({.[0] eq[~] .[1]»[1]},map |*,[Z] map {.[0]X [X] map {.comb[(^$_,$_,$_^..* for ^.chars)]},.[1..*]},a.permutations)[1] ->$/ {say [~] " "x a.comb-$0,|$0,$1.uc,|$2}}

Solución de fuerza bruta.

Cómo funciona

-> \a {
    for first({.[0] eq[~] .[1]»[1]},          # For the first valid candidate
            map |*, [Z]                       # among the transposed
            map {                             # lists of candidates
                .[0] X [X] map {
                    .comb[(^$_,$_,$_^..* for ^.chars)]
                }, .[1..*]
            },
            a.permutations                    # for all permutations of the input:
        )[1] ->$/ {
        say [~] " "x a.comb-$0,|$0,$1.uc,|$2  # Print the candidate as ASCII art.
    }
}

Cada candidato se ve así:

"of", (("c"),"o",("w")), ((),"f",("o","x"))

La transposición de la lista de listas de candidatos es necesaria para garantizar que se encuentre un acróstico, si existe, antes de cualquier mesostico.