path: root/js/games/nluqo.github.io/~bh/downloads/csls-programs/crypto

to crypto :text
make "text map "uppercase :text
make "fulltext :text
make "moretext []
make "textstack []
if not procedurep "letterp [copydef "letterp "namep]
forletters "A "Z "initvars
make "maxcount 0
initcount "single
initcount "triple
cleartext
histogram :text
redisplay "false
if or guess.single guess.triple [showclear :text]
parseloop
end

;; Initialization

to initcount :type
setlist. :type []
setcount. :type 0
end

to initvars :letter
setcnt :letter 0
make :letter "| |
setunbound :letter
end

;; Histogram

to histogram :text
foreach :text [localmake "word filter "letterp ?
               foreach :word "histlet
               prepare.guess :word]
end

to histlet :letter
localmake "cnt 1+cnt :letter
setcursor list (index :letter) (nonneg 24-:cnt)
type :letter
setcnt :letter :cnt
if :maxcount < :cnt [make "maxcount :cnt]
end

;; Guessing letters

to prepare.guess :word
if equalp count :word 1 [tally "single :word]
if equalp count :word 3 [tally "triple :word]
end

to tally :type :word
localmake "countvar word :type :word
if not memberp :word list. :type ~
   [setlist. :type fput :word list. :type   make :countvar 0]
localmake "count (thing :countvar)+1
make :countvar :count
if :count > (count. :type) ~
   [setcount. :type :count   setmax. :type :word]
end

to guess.single
if emptyp (list. "single) [output "false]
if emptyp butfirst (list. "single) ~
   [qbind first (list. "single) "A  output "true]
qbind (max. "single) "A
qbind (ifelse equalp first (list. "single) (max. "single)
              [last (list. "single)]
              [first (list. "single)]) ~
      "I
output "true
end

to guess.triple
if emptyp (list. "triple) [output "false]
if :maxcount < (3+cnt last (max. "triple))	 ~
   [qbind first (max. "triple) "T
    qbind first butfirst (max. "triple) "H
    qbind last (max. "triple) "E
    output "true]
output "false
end

;; Keyboard commands

to parseloop
forever [parsekey uppercase readchar]
end

to parsekey :char
if :char = "@ [fullclear stop]
if :char = "+ [moretext stop]
if :char = "- [lesstext stop]
if not letterp :char [beep stop]
bind :char uppercase readchar
end

;; Keeping track of guesses

to bind :from :to
if not equalp :to "| | [if not letterp :to [beep stop]
                        if boundp :to [beep stop]]
if letterp thing :from [dark thing :from]
make :from :to
fixtop :from
if letterp :to [light :to]
showclear :text
end

to qbind :from :to
if letterp thing :from [stop]
make :from :to
fixtop :from
light :to
end

;; Maintaining the display

to redisplay :flag
cleartext
showtop
alphabet
showcode :text
if :flag [showclear :text]
end

;; Top section of display (letter counts and guesses)

to showtop
setcursor [0 0]
showrow "A "E
showrow "F "J
showrow "K "O
showrow "P "T
showrow "U "Y
showrow "Z "Z
end

to showrow :from :to
forletters :from :to [setposn ? cursor   onetop ?]
print []
end

to onetop :letter
localmake "count cnt :letter
if :count = 0 [type word :letter "|      | stop]
localmake "text (word :letter "- twocol :count "- thing :letter)
ifelse :maxcount < :count+3 [invtype :text] [type :text]
type "| |
end

to twocol :number
if :number > 9 [output :number]
output word 0 :number
end

to fixtop :letter
setcursor posn :letter
onetop :letter
end

;; Middle section of display (guessed cleartext letters)

to alphabet
setcursor [6 6]
forletters "A "Z [ifelse boundp ? [invtype ?] [type ?]]
end

to light :letter
setcursor list 6+(index :letter) 6
invtype :letter
setbound :letter
end

to dark :letter
setcursor list 6+(index :letter) 6
type :letter
setunbound :letter
end

;; Bottom section of display (coded text)

to showcode :text
make "moretext []
showcode1 8 0 :text
end

to showcode1 :row :col :text
if emptyp :text [make "moretext [] stop]
if :row > 22 [stop]
if and equalp :row 16 equalp :col 0 [make "moretext :text]
if (:col+count first :text) > 37 [showcode1 :row+2 0 :text stop]
codeword :row :col first :text
showcode1 :row (:col+1+count first :text) butfirst :text
end

to codeword :row :col :word
setcursor list :col :row
invtype :word
end

;; Bottom section of display (cleartext)

to showclear :text
showclear1 8 0 :text 2
end

to showclear1 :row :col :text :delta
if emptyp :text [stop]
if :row > 23 [stop]
if keyp [stop]
if (:col+count first :text) > 37 ~
   [showclear1 :row+:delta 0 :text :delta stop]
clearword :row :col first :text
showclear1 :row (:col+1+count first :text) butfirst :text :delta
end

to clearword :row :col :word
setcursor list :col :row+1
foreach :word [ifelse letterp ? [type thing ?] [type ?]]
end

;; Windowing commands

to fullclear
cleartext
showclear1 0 0 :fulltext 1
print []
invtype [type any char to redisplay]
ignore readchar
redisplay "true
end

to moretext
if emptyp :moretext [beep stop]
push "textstack :text
make "text :moretext
redisplay "true
end

to lesstext
if emptyp :textstack [beep stop]
make "text pop "textstack
redisplay "true
end

;; Iteration tool for letters

to forletters :from :to :action
for [lettercode [ascii :from] [ascii :to]] ~
    [apply :action (list char :lettercode)]
end

;; Data abstraction (constructors and selectors)

to setbound :letter
make word "bound :letter "true
end

to setunbound :letter
make word "bound :letter "false
end

to boundp :letter
output thing word "bound :letter
end

to setcnt :letter :thing
make (word "cnt :letter) :thing
end

to cnt :letter
output thing (word "cnt :letter)
end

to setposn :letter :thing
make (word "posn :letter) :thing
end

to posn :letter
output thing (word "posn :letter)
end

to setcount. :word :thing
make (word "count. :word) :thing
end

to count. :word
output thing (word "count. :word)
end

to setlist. :word :thing
make (word "list. :word) :thing
end

to list. :word
output thing (word "list. :word)
end

to setmax. :word :thing
make (word "max. :word) :thing
end

to max. :word
output thing (word "max. :word)
end

;; Miscellaneous helpers

to index :letter
output (ascii :letter)-(ascii "A)
end

to beep
tone 440 15
end

to invtype :text
type standout :text
end

to nonneg :number
output ifelse :number < 0 [0] [:number]
end

;; Sample cryptograms

make "cgram1 [Dzynufqyjulli, jpqhq ok yr hoxpj qnzeujory qceqwj xhrtoyx
   zw oyjr u trhjptpolq trhln. oynqqn, rzh qceqkkogq eryeqhy tojp
   whrvlqfk rd qnzeujory uj whqkqyj kofwli fquyk jpuj jpq |xhrty-zwk| nr
   yrj pugq kzep u trhln. u nqeqyj qnzeujory uofk uj, whqwuhqk drh, u
   frhq trhjptpolq dzjzhq, tojp u noddqhqyj erffzyoji kwohoj, noddqhqyj
   reezwujoryk, uyn frhq hqul zjoloji jpuy ujjuoyoyx kjujzk uyn kuluhi.]

make "cgram2 [Lvo vfkp lfzj md opaxflimn iz lm gitokflo fnp zlkonblvon f
   hmalv'z inilifliuo, fnp fl lvo zfyo liyo lm zoo lm il lvfl vo jnmwz
   wvfl iz noxozzfkh lm xmco wilv lvo mnbminb fxliuilioz fnp xaglako md
   zmxiolh, zm lvfl viz inilifliuo xfn to kogoufnl. il iz ftzakp lm
   lvinj lvfl lviz lfzj xfn to fxxmycgizvop th zm yaxv zillinb in f tms
   dfxinb dkmnl, yfnicagflinb zhytmgz fl lvo pikoxlimn md pizlfnl
   fpyinizlkflmkz. lviz iz kflvok f wfh lm kobiyonl fnp tkfinwfzv.]

make "cgram3 [Pcodl hbdcx qxdrdlh yihcodr, hbd rzbiier gxd lih ziyqdhdlh
   hi hdgzb gwhbdlhcz echdxgzf, xdgnclp gr g ydglr ia ecudxghcil gln
   zwehcoghcil. gln c niwuh hbgh yirh ia wr jbi rdxciwref xdgn gln jxchd
   hbd dlpecrb eglpwgpd dodx edgxldn ch uf hbd xiwhd ia "xwl, rqih, xwl"
   hi rcegr ygxldx.]

make "cgram4 [Jw btn xnsgsyp ejke gfebbcg, dtyjbn fbccsksg, ryu fbccsksg
   nswcsfpsu pes usgjns, wnssuba, ryu wtptns bw pes qbtyk, pesns zbtcu
   ls yb knrujyk, yb psgpjyk svfsxp rg r psrfejyk aspebu, ryu yb
   lcrfilbrnu dtykcsg. jy wrfp, zs rns ksppjyk cbfigpsx gfesutcjyk ryu
   knrujyk pb pes xbjyp bw pbnptns.]