to a_sand
;***************************************
; Cifrado de Arena
;***************************************
;letras múltiples
make "version "Cifrado-de-arena
make "ruido_interno "true
make "cada_cuanto 9
make "fuente labelfont
make "ancho_texto 72 ; para formatear los textos de salida
make "nc 0
cs
copy_right
ht
pu
make "ponfecha "false
make "texto_plano "
make "texto_cifrado "
make "clave_inicial []
make "clave []
bury [[][texto_plano texto_cifrado  clave clave_inicial fichero_datos fichero_destino][]]
;setheading -135
;fd 100
;setheading -90
;fd 100
;gifload "dados.gif
pennormal
closeall
setwrite []
;rerandom ; por si acaso
;make "version "SAND-2.0
make "indicador_de_cifrado "sand
make "indicador_de_descifrado "-dnas
repeat 10 [print "]
make "caseignoredp "true
prepara_dado
;(rerandom 31416)
alfabeto
;make "alfabeto_al aleatoriza :alfa_base []
make "alfabeto_al :alfa_base
pide_datos
make "longi_fiche mide_fichero :fichero_datos
make "angulo 360/(9*:longi_fiche)
pu
home
back 100
;st
informacion [procesando...]
make "clave procesa_clave :clave_inicial []
;****************** dos opciones : insertar la clave******
;make "alfabeto_al2 inserta_clave :clave :alfabeto_al []
;*********************************************************
;**************o ponerla al principio ********************
make "alfabeto_al2 se :clave :alfabeto_al
;**********************************************************
make "alfabeto_al3 escanea_alfabeto :alfabeto_al2 []
reparte :alfabeto_al3 
asigna_coordenadas
ifelse :cifrar [cifra_sand][descifra_sand]
make "fuente_normal labelfont
make "fuente labelfont
make "fuente0 labelfont
;setlabelfont [[Courier] -24 0 0 400 0 0 0 0 3 2 1 18] 
;setpencolor [000 000 000]
pu
; ***
erns ;**** borra las variables *****
make "startup [a_sand]
ifelse (yesnobox [Cifrado de arena] [¿Qiere volver a cifrar o descifrar?]) [a_sand][bye]
end

to aleatoriza :alfa :alfa_al
if emptyp :alfa [op :alfa_al stop]
make "alea 1 + random count :alfa 
make "letra item :alea :alfa
make "alfa_al lput :letra :alfa_al
make "alfa quita :alea :alfa []
op aleatoriza :alfa :alfa_al
end

to alfabeto
make "alfa_base [A 0 B 1 C 2 D 3 E 4 F 5 G 6 H 7 I 8 J 9 K . L , M E N A Ñ O O L P S Q N R E S - T - U V W X Y Z]
;make "alfa_base  [a a a a b c d e e e e e f g h i j k l m n n ñ o o o p q w r s s t u v w x y z - - - - - - - - -]
;Make "alfa_base [A B C D E F G H I J K L M N Ñ O P Q R S T U V W X Y Z - 0 1 2 3 4 5 6 7 8 9 E A O L S N - - - -]
make "multiples [- E A O N L S]
make "nguiones 2
make "ne 3
make "na 2
make "no 2
make "nn 2
make "ns 2
make "nl 2
make "unicas []
make "guion_rep []
make "e_rep []
make "a_rep []
make "o_rep []
make "n_rep []
make "s_rep []
make "l_rep []
make "acentuadas [á é í ó ú Á É Í Ó Ú à è ì ò ù À È Ì Ò Ù ä ë ï ö ü Ä Ë Ï Ö Ü â ê î ô û Â Ê Î Ô Û]
make "sin_acentuar [A E I O U A E I O U A E I O U A E I O U A E I O U A E I O U A E I O U A E I O U]
make "minusculas [a b c d e f g h i j k l m n ñ o p q r s t u v w x y z]
make "mayusculas [A B C D E F G H I J K L M N Ñ O P Q R S T U V W X Y Z]
end

to asigna :carafila :cara :fila :col 
if emptyp :carafila [stop]
make "letra first :carafila
ifelse memberp :letra :dado [make :letra lput (list :cara :fila :col) thing :letra][make :letra [] make "dado lput :letra :dado make :letra (list (list :cara :fila :col))]
asigna bf :carafila :cara :fila :col + 1
end

to asigna_coordenadas
make "dado []
asigna :cara1fila1 1 1 1
asigna :cara1fila2 1 2 1
asigna :cara2fila1 2 1 1
asigna :cara2fila2 2 2 1 
asigna :cara3fila1 3 1 1
asigna :cara3fila2 3 2 1
asigna :cara4fila1 4 1 1
asigna :cara4fila2 4 2 1
asigna :cara5fila1 5 1 1
asigna :cara5fila2 5 2 1
asigna :cara6fila1 6 1 1
asigna :cara6fila2 6 2 1
end

to cifra :texto :cifrado
if emptyp :texto [op :cifrado stop]
make "letra first :texto
make "l_cif codifica :letra 
;print list "l_cif :l_cif
;rt:angulo
op cifra bf :texto word :cifrado :l_cif
end

to cifra_sand
make "texto_plano lee_datos_plano
make "texto_cifrado cifra :texto_plano "
(openwrite :fichero_destino "TRUE)
setwrite :fichero_destino
guarda :texto_cifrado
close :fichero_destino
setwrite []
windowfileedit :fichero_destino []
end

to codifica :letra 
;print :letra
;print thing :letra
make "coordenadas first thing :letra ;(1 + random count (thing :letra)) thing :letra
make :letra bf lput first thing :letra thing :letra ;pone la primera posibilidad al final
;show :coordenadas
make "cara item 1 :coordenadas
;print :cara
make "fila item 2 :coordenadas
;print :fila
make "columna item 3 :coordenadas
;print :columna
if :cara = 1 [make "cod_cara first :cod_cara1 make "cod_cara1 bf lput first :cod_cara1 :cod_cara1]
if :cara = 2 [make "cod_cara first :cod_cara2 make "cod_cara2 bf lput first :cod_cara2 :cod_cara2]
if :cara = 3 [make "cod_cara first :cod_cara3 make "cod_cara3 bf lput first :cod_cara3 :cod_cara3]
if :cara = 4 [make "cod_cara first :cod_cara4 make "cod_cara4 bf lput first :cod_cara4 :cod_cara4]
if :cara = 5 [make "cod_cara first :cod_cara5 make "cod_cara5 bf lput first :cod_cara5 :cod_cara5]
if :cara = 6 [make "cod_cara first :cod_cara6] ; sólo hay una posibilidad
 
make "cod_fila item :fila [: .]
;print :cod_fila
if :columna = 1 [make "cod_columna first :cod_columna1 make "cod_columna1 bf lput first :cod_columna1 :cod_columna1]
if :columna = 2 [make "cod_columna first :cod_columna2 make "cod_columna2 bf lput first :cod_columna2 :cod_columna2]
if :columna = 3 [make "cod_columna first :cod_columna3 make "cod_columna3 bf lput first :cod_columna3 :cod_columna3]
if :columna = 4 [make "cod_columna first :cod_columna4] ; sólo hay una posibilidad
;make "asda readlist (?)
op (word :cod_cara :cod_fila :cod_columna)
end

to continuar
ifelse (yesnobox [Cifrado de arena] [¿Qiere volver a cifrar o descifrar?]) [a_sand][bye]
end

to copy_right
;home 
;left 135
pu
;fd 400
;rt 45
;rt 180
make "nafuente labelfont
setlabelfont [[Times New Roman] -48 0 90 400 0 0 0 0 3 2 1 18]  
labelaTNR [-180 120] (list :version) 40
setlabelfont :fuente  
make "fuente labelfont
setlabelfont [[Courier] -17 0 0 400 0 0 0 0 3 2 1 18]  
labela [-180 60][UNA COPRODUCCIÓN INFER-LESTIAL] 9
labela [-180 40][infosniper (a las maracas y cubilete) & Agustín (a los teclados)] 9
labela [-180 20][Versión FMSLogo de Agustín Sánchez] 9
pd
setlabelfont :fuente 
end

to corta_clave :al :al_salida
localmake "buffer []
repeat (count :clave - 1) [make "buffer fput last :al make "al bl :al] ; toma los caractres del final del alfabeto
op se :buffer :al
end

to descifra :cif :cla
if emptyp :cif [op :cla stop]
make "c_cara (word (item 1 :cif)(item 2 :cif)(item 3 :cif))
repeat 3 [make "cif bf :cif]
if memberp :c_cara [**. *.* .**] [make "cara 1]
if memberp :c_cara [*.. .*. ..* **: *:* :**][make "cara 2]
if memberp :c_cara [... *.: .*: .:* *:. :*. :.*][make "cara 3]
if memberp :c_cara [*:: :*: ::* ..: .:. :..][make "cara 4]
if memberp :c_cara [::. :.: .::][make "cara 5]
if memberp :c_cara [:::][make "cara 6]
make "c_fila first :cif
make "cif bf :cif
ifelse :c_fila = ": [make "fila 1][make "fila 2]
make "c_col word item 1 :cif item 2 :cif
make "cif bf bf :cif   
if memberp :c_col [*. .*][make "col 1]
if memberp :c_col [.. *: :*][make "col 2] 
if memberp :c_col [.: :.][make "col 3]
if memberp :c_col [::][make "col 4]
if and (:cara = 1)(:fila = 1)[make "cacho :cara1fila1]
if and (:cara = 1)(:fila = 2)[make "cacho :cara1fila2]
if and (:cara = 2)(:fila = 1)[make "cacho :cara2fila1]
if and (:cara = 2)(:fila = 2)[make "cacho :cara2fila2]
if and (:cara = 3)(:fila = 1)[make "cacho :cara3fila1]
if and (:cara = 3)(:fila = 2)[make "cacho :cara3fila2]
if and (:cara = 4)(:fila = 1)[make "cacho :cara4fila1]
if and (:cara = 4)(:fila = 2)[make "cacho :cara4fila2]
if and (:cara = 5)(:fila = 1)[make "cacho :cara5fila1]
if and (:cara = 5)(:fila = 2)[make "cacho :cara5fila2]
if and (:cara = 6)(:fila = 1)[make "cacho :cara6fila1]
if and (:cara = 6)(:fila = 2)[make "cacho :cara6fila2]
;;print (list :cara :fila :col)
;show :cacho
;;print "->
;make "dkd readlist
make "plana item :col :cacho
;print :plana
op descifra :cif word :cla :plana
end

to descifra_sand
make "texto_cifrado lee_datos_cifrado
make "texto_plano descifra :texto_cifrado "
(openwrite :fichero_destino "true)
setwrite :fichero_destino
guarda_plano :texto_plano
close :fichero_destino
setwrite []
windowfileedit :fichero_destino [] 
end

to destino_cifrado :nomc :ex
make "ex ".txt ;cifra_ext :ex :clave_compacta "
ifelse  :ponfecha [op (word :nomc "- :hora "- :indicador_de_cifrado :ex)][op (word :nomc "- :indicador_de_cifrado :ex)]
end

to destino_descifrado :nomd :ex
make "ex ".txt ;cifra_ext :ex :clave_compacta "
op (word :nomd :indicador_de_descifrado :ex)
end

to escanea_alfabeto :al :al_fin
if emptyp :al [op :al_fin stop]
make "letrita first :al
make "al bf :al
if not memberp :letrita :multiples [if not memberp :letrita :unicas [make "unicas lput :letrita :unicas  ~
                                    make "al_fin lput :letrita :al_fin] op escanea_alfabeto :al :al_fin stop]
; por aquí pasa si es letra múltiple 
if and (:letrita = "-) ((count :guion_rep) < :nguiones) [make "guion_rep lput :letrita :guion_rep ~
                                                   make "al_fin lput :letrita :al_fin]
if and (:letrita = "E) ((count :e_rep) < :ne) [make "e_rep lput :letrita :e_rep ~
                                                   make "al_fin lput :letrita :al_fin]
if and (:letrita = "A) ((count :a_rep) < :na) [make "a_rep lput :letrita :a_rep ~
                                                   make "al_fin lput :letrita :al_fin]
if and (:letrita = "O) ((count :o_rep) < :no) [make "o_rep lput :letrita :o_rep ~
                                                   make "al_fin lput :letrita :al_fin]
if and (:letrita = "N) ((count :n_rep) < :nn) [make "n_rep lput :letrita :n_rep ~
                                                   make "al_fin lput :letrita :al_fin]
if and (:letrita = "S) ((count :s_rep) < :ns) [make "s_rep lput :letrita :s_rep ~
                                                   make "al_fin lput :letrita :al_fin]
if and (:letrita = "L) ((count :l_rep) < :nl) [make "l_rep lput :letrita :l_rep ~
                                                   make "al_fin lput :letrita :al_fin]

op escanea_alfabeto :al :al_fin
end

to guarda :tx_cif
if emptyp :tx_cif [stop]
if :nc = :ancho_texto [make "nc 0 type char 13 TYPE CHAR 10]
make "nc :nc + 1
make "car first :tx_cif
ifelse :car = "* [type char 32][type :car]
;rt:angulo
guarda bf :tx_cif
end

to guarda_plano :tex_pl
if emptyp :tex_pl [stop]
if :nc = :ancho_texto [make "nc 0 type char 13 TYPE CHAR 10]
make "nc :nc + 1
type first :tex_pl
;rt:angulo
guarda_plano bf :tex_pl
end

to informacion :lista
repeat 10 [print "]
print "************INFORMACIÓN***********
print "*
print se "* :lista
print "*
print "**********************************
end

to inserta_clave :cl :al1 :al2
make "clavo first :cl
inserta_clave2
make "al2 corta_clave :al2 
end

to inserta_clave2
make "ranura first :al1
make "al2 bf :al1
ifelse equalp :ranura :clavo [make "al2 (se :al2 :cl :al1) stop][make "al2 lput :ranura :al2]
inserta_clave2
end

to labela :lpos :l :k
pu
setheading 270
setpos :lpos
labela2 :l
end

to labela2 :l
if emptyp :l [pu home stop]
make "ll sum 1 count first :l
pd
label first :l 
pu
bk round product :ll :k 
;bk 5
;ifelse equalp :segundero :segundo [make "segundero 0 ; ; update][make "segundero :segundero + 1]
labela2 bf :l
end

to labela2ntr :l
if emptyp :l [pu home stop]
make "ll sum 1 count first :l
pd
label first :l 
pu
fd round product :ll :k 
;bk 5
;ifelse equalp :segundero :segundo [make "segundero 0 ; ; update][make "segundero :segundero + 1]
labela2 bf :l
end

to labelaTNR :lpos :l :k
pu
setheading 90
setpos :lpos
labela2ntr :l
end

to lee_datos_cifrado
openread :fichero_datos
setread :fichero_datos
op lee_datos_cifrado2 "
close :fichero_datos
end

to lee_datos_cifrado2 :text_cif
if eofp [op :text_cif stop]
make "car readchar
;rt:angulo
if (ascii :car) = 32 [make "text_cif word :text_cif "*]
if memberp :car [. :] [make "text_cif word :text_cif :car]
op lee_datos_cifrado2 :text_cif
end

to lee_datos_plano
(openread :fichero_datos "true)
setread :fichero_datos
op lee_datos_plano2 "
close :fichero_datos
end

to lee_datos_plano2 :text_pl ; se evita que se escriban caracteres ruido consecutivos
if eofp [op :text_pl stop]
ifelse not emptyp :text_pl [make "ultimo_car last :text_pl][make "ultimo_car "]
make "ya_hay_ruido (equalp :ultimo_car "-)
make "car char readchar
if (ascii :car) = 10 [make "car "-]
if (ascii :car) = 32 [make "car "-]
if and (equalp "- :car) :ya_hay_ruido [op lee_datos_plano2 :text_pl stop] ; salta el guión, porque ya hay uno en el texto
if and (equalp "- :car) (not :ya_hay_ruido) [op lee_datos_plano2 word :text_pl :car stop] ; pega elguión altexto
;sólo pasa por aquí si no es un -
if memberp :car :acentuadas [make "car quita_acento :car]
if not memberp :car :alfabeto_al3 [make "car "]
make "text_pl word :text_pl :car
if and (:ruido_interno) (not :ya_hay_ruido) [make "alea random :cada_cuanto if :alea = 0 [make "text_pl word :text_pl "-]]
op lee_datos_plano2 :text_pl
end

to mide_fichero :fichero
local "longi
catch "error [openupdate :fichero]
if not emptyp error [close :fichero openupdate :fichero]  ;informacion se [Haga el puto favor de cerrar el fichero] :fichero]] 
setread :fichero
make "longi readpos
close :fichero
;ifelse equalp :segundero :segundo [make "segundero 0 ; ; update][make "segundero :segundero + 1]
op :longi
end

to obtiene_extension :nf :ex
if emptyp :nf [op :ex stop]
make "ex word :ex first :nf
;ifelse equalp :segundero :segundo [make "segundero 0 ; ; update][make "segundero :segundero + 1]
op obtiene_extension bf :nf :ex
end

to obtiene_nombre :nf :nn
if equalp ". first :nf [op :nn stop]
make "nn word :nn first :nf
;ifelse equalp :segundero :segundo [make "segundero 0 ; ; update][make "segundero :segundero + 1]
op obtiene_nombre bf :nf :nn
end

to pasa_a_may :letrita
ifelse memberp :letrita :minusculas [make "pos_min posicion :letrita :minusculas op item :pos_min :mayusculas][op :letrita] 
end

to pide_datos
informacion [Escriba la clave. Recuerde las normas de seguridad]
make "clave_inicial questionbox [Cifrado de arena] [Clave: (escribir o pegar)]
make "opcion selectbox [Elija tarea] [Cifrar Descifrar]
make "cifrar equalp 1 :opcion
ifelse :cifrar [pide_fichero_cifrar make "fichero_destino destino_cifrado :nombre_cifrar :extension]~
               [pide_fichero_descifrar make "fichero_destino destino_descifrado :nombre_descifrar :extension]    
end

to pide_fichero_cifrar
informacion [Elija el fichero a cifrar]
make "fichero_datos dialogfileopen "*.txt
;windowfileedit :fichero_datos []
make "nombre_cifrar obtiene_nombre :fichero_datos "
make "extension "txt
end

to pide_fichero_descifrar
informacion [Elija fichero a descifrar]
make "fichero_datos dialogfileopen "*.txt
make "nombre_descifrar obtiene_nombre :fichero_datos "
make "extension "txt
end

to posicion :letra :lista_o_palabra
ifelse memberp :letra :lista_o_palabra [op (count :lista_o_palabra) - (count member :letra :lista_o_palabra) + 1][op 0]
end

to posiciones :letra :lista_o_palabra :pos :ant
; encuentra todas las posiciones de :letra en :lista_o_palabra y las devuelve en la lista :pos 
if not memberp :letra :lista_o_palabra [op :pos stop]
make "ocurrencia member :letra :lista_o_palabra
make "primera posicion :letra :lista_o_palabra
make "nueva :primera + :ant
make "pos lput :nueva :pos
make "ant :nueva
repeat :primera [make "lista_o_palabra bf :lista_o_palabra]
op posiciones :letra :lista_o_palabra :pos :ant 
end

to prepara_dado
make "cara1fila1 []
make "cara1fila2 []
make "cara2fila1 []
make "cara2fila2 []
make "cara3fila1 []
make "cara3fila2 []
make "cara4fila1 []
make "cara4fila2 []
make "cara5fila1 []
make "cara5fila2 []
make "cara6fila1 []
make "cara6fila2 []
make "cod_cara1 [**. *.* .**]
make "cod_cara2 [*.. .*. ..* **: *:* :**]
make "cod_cara3 [... *.: .*: .:* *:. :*. :.*]
make "cod_cara4 [*:: :*: ::* ..: .:. :..]
make "cod_cara5 [::. :.: .::]
make "cod_cara6 [:::]
make "cod_columna1 [*. .*]
make "cod_columna2 [.. *: :*]
make "cod_columna3 [.: :.]
make "cod_columna4 [::]
end

to procesa_clave :cl1 :cl2
if emptyp :cl1 [op :cl2 stop]
make "pal1 first :cl1
make "cl1 bf :cl1 
procesa_pal :pal1
op procesa_clave :cl1 :cl2
end

to procesa_pal :p1
if emptyp :p1 [if not emptyp :cl1 [make "cl2 lput "- :cl2] stop] ; añade un guión si hay más palabras
make "letrita first :p1
if memberp :letrita :acentuadas [make "letrita quita_acento :letrita]
if memberp :letrita :alfabeto_al [make "letrita pasa_a_may :letrita make "cl2 lput :letrita :cl2]
procesa_pal bf :p1
end

to quita :np :al :al2
repeat :np - 1 [make "al2 lput first :al :al2 make "al bf :al] ; pasa los anteriores
make "al bf :al ; quita el afectado
make "al2 se :al2 :al
op :al2
end

to quita_acento :acen
make "pos_acent posicion :acen :acentuadas
op item :pos_acent :sin_acentuar
end

to reparte :al 
reparte1 1
reparte2 1
end

to reparte1 :nl
if emptyp :al [stop]
if :nl > 4 [stop]
make "letra first :al
make "cara1fila1 lput :letra :cara1fila1
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara2fila1 lput :letra :cara2fila1
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara3fila1 lput :letra :cara3fila1
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara4fila1 lput :letra :cara4fila1
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara5fila1 lput :letra :cara5fila1
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara6fila1 lput :letra :cara6fila1
make "al bf :al
;*******************
reparte1 :nl + 1
end

to reparte2 :nl
if emptyp :al [stop]
if :nl > 4 [stop]
make "letra first :al
make "cara1fila2 lput :letra :cara1fila2
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara2fila2 lput :letra :cara2fila2
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara3fila2 lput :letra :cara3fila2
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara4fila2 lput :letra :cara4fila2
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara5fila2 lput :letra :cara5fila2
make "al bf :al
;*******************
if emptyp :al [stop]
make "letra first :al
make "cara6fila2 lput :letra :cara6fila2
make "al bf :al
;*******************
reparte2 :nl + 1
end

Make "startup [a_sand]