проФорт

Задачка 6

Задание похожее на то что встречалось ранее, требуется пройти по цепочке файлов, каждый из которых содержит имя cледующего файла в цепочке. Распаковываем требуемые по условию файлы в каталог 6.

Решение

REQUIRE STR@ ~ac/lib/str5.f
REQUIRE /STRING lib/include/string.f
REQUIRE NUMBER ~ygrek/lib/parse.f

: filename ( n -- s ) " 6\{n}.txt" ;

: prompt S" Next nothing is " ;

: extract ( a u -- n )
   prompt SEARCH 0= IF 2DROP 0 EXIT THEN
   prompt NIP /STRING
   NUMBER 0= IF 0 EXIT THEN ;

: next
   BEGIN
    DUP CR ." GO TO " .
    filename
    >R
    R@ STR@ FILE R> STRFREE
    2DUP CR TYPE
    extract
    DUP 0=
   UNTIL
   DROP
   CR ." STOP" ;

90052 next

И в результате получим 'Collect the comments.' Оказывается у файлов в zip архиве есть комментарии - выдрать их простым способом не получится - поэтому пришлось опять подсмотреть ответ :-(


Задачка 7

Требуется из заданного рисунка выбрать несколько пикселей и преобразовать их цветовые компоненты в коды символов. Либы для работы с PNG изображениями нетути и поэтому качаем файл и преобразовав его каким-нибудь сторонним софтом в формат BMP (24-битный), переименовываем в 7.bmp

Решение

Слово doit выводит красную компоненту требуемых пикселей как символы на стандартный выход. Словом TYPE>STR мы перехватываем этот вывод в строку, выделяем часть закодированную числами, разбиваем по запятым с помощью bac4th слова split ( a u f <--> s1 ) (разбивает строку a u символами, на которых функция f даст TRUE и генерирует вызов для каждой последовательности между этими символами с автоматическим выделением и снятием памяти), заметьте что функция f генерируется автоматически (и удаляется на обратном ходу) словом byChar ( char <--> f ).

REQUIRE CBMP24 ~ygrek/lib/spec/bmp.f
REQUIRE TYPE>STR ~ygrek/lib/typestr.f
REQUIRE /STRING lib/include/string.f
REQUIRE split ~profit/lib/bac4th-str.f
REQUIRE NUMBER ~ygrek/lib/parse.f
REQUIRE SPLIT- ~pinka/samples/2005/lib/split.f
REQUIRE FINE-HEAD ~pinka/samples/2005/lib/split-white.f

CBMP24 NEW img
S" 7.bmp" img :load-file

: doit
   img sizeX @ 0 DO
     I 45 img :rgb 2DROP EMIT
   7 +LOOP ;

: solve
   ['] doit TYPE>STR STR@ 2DUP CR TYPE
   S" [" SEARCH 0= ABORT" BAD1"
   1 /STRING
   S" ]" SPLIT- 0= ABORT" BAD2"
   2SWAP 2DROP
   2DUP CR TYPE
   CR
   START{
     [CHAR] , byChar split
     DUP STR@
     FINE-HEAD FINE-TAIL NUMBER 0= ABORT" not number" EMIT
   }EMERGE
;

solve

Задачка 8

Требуется расквотировать две строки - произвольные символы задаются либо явно, либо последовательностью \xXX для символа с шестнадцатеричным кодом XX, либо \r для символа перевода строки.
В результате получаем нечто, на поверку представляющее собой BZip упакованные данные. Распаковав их (сторонним софтом) получим логин и пароль для доступа к следующим уровням.

Решение

REQUIRE NUMBER ~ygrek/lib/parse.f
REQUIRE /STRING lib/include/string.f
REQUIRE TYPE>STR ~ygrek/lib/typestr.f
REQUIRE OCCUPY ~pinka/samples/2005/lib/append-file.f
REQUIRE UPPERCASE ~ac/lib/string/uppercase.f

: peek ( a u -- c ) 0= THROW C@ ;
: next ( a u -- a1 u1 c ) 2DUP peek >R 1 /STRING R> ;
: HEX-NUMBER ( a u -- n ) BASE @ >R HEX NUMBER R> BASE ! ;

CREATE buf 2 ALLOT

: decode\xXX ( a u -- a2 u2 c )
   next
   DUP [CHAR] r = IF DROP 0x0D EXIT THEN
   [CHAR] x <> ABORT" ERROR1"
   DUP 2 < ABORT" ERROR2"
   2 /GIVE
   2DUP UPPERCASE HEX-NUMBER 0= ABORT" ERROR3" ;

: decode ( a u -- )
   BEGIN
    next DUP [CHAR] \ = IF DROP decode\xXX THEN
    EMIT
    DUP 0=
   UNTIL 2DROP ;

: un S" BZh91AY&SYA\xaf\x82\r\x00\x00\x01\x01\x80\x02\xc0\x02\x00 \x00!\x9ah3M\x07<]\xc9\x14\xe1BA\x06\xbe\x084" ;
: pw S" BZh91AY&SY\x94$|\x0e\x00\x00\x00\x81\x00\x03$ \x00!\x9ah3M\x13<]\xc9\x14\xe1BBP\x91\xf08" ;

un ' decode TYPE>STR DUP STR@ S" 8login.bz2" OCCUPY STRFREE
pw ' decode TYPE>STR DUP STR@ S" 8password.bz2" OCCUPY STRFREE
CR .( DONE)

Задачка 9

Задание с красноречивым названием 'connect the dots'. Задан набор координат, проведя линии соединяющие последовательно точки заданные этими координатами получим рисунок.

Решение

Для отрисовки воспользуемся обьектно-ориентированной OpenGL библиотечкой. Уже привычная последовательность [CHAR] , byChar split для выдирания чисел обрамлена в скобки %[ ... ]% для создания списка чисел. Слово % ( n -- ) внутри этих скобок добавляет n в новый список. Остальное - вспомогательный код для создания линий и отображения их в GL окне.

REQUIRE replace-str- ~pinka/samples/2005/lib/replace-str.f
REQUIRE GLWindow     ~ygrek/lib/joopengl/GLWindow.f
REQUIRE lst(         ~ygrek/lib/list/ext.f
REQUIRE split        ~profit/lib/bac4th-str.f
REQUIRE NUMBER       ~ygrek/lib/parse.f

" 146,399,163,403,170,393,169,391,166,386,170,381,170,371,170,355,169,346,167,335,170,329,170,320,170,
310,171,301,173,290,178,289,182,287,188,286,190,286,192,291,194,296,195,305,194,307,191,312,190,316,
190,321,192,331,193,338,196,341,197,346,199,352,198,360,197,366,197,373,196,380,197,383,196,387,192,
389,191,392,190,396,189,400,194,401,201,402,208,403,213,402,216,401,219,397,219,393,216,390,215,385,
215,379,213,373,213,365,212,360,210,353,210,347,212,338,213,329,214,319,215,311,215,306,216,296,218,
290,221,283,225,282,233,284,238,287,243,290,250,291,255,294,261,293,265,291,271,291,273,289,278,287,
279,285,281,280,284,278,284,276,287,277,289,283,291,286,294,291,296,295,299,300,301,304,304,320,305,
327,306,332,307,341,306,349,303,354,301,364,301,371,297,375,292,384,291,386,302,393,324,391,333,387,
328,375,329,367,329,353,330,341,331,328,336,319,338,310,341,304,341,285,341,278,343,269,344,262,346,
259,346,251,349,259,349,264,349,273,349,280,349,288,349,295,349,298,354,293,356,286,354,279,352,268,
352,257,351,249,350,234,351,211,352,197,354,185,353,171,351,154,348,147,342,137,339,132,330,122,327,
120,314,116,304,117,293,118,284,118,281,122,275,128,265,129,257,131,244,133,239,134,228,136,221,137,
214,138,209,135,201,132,192,130,184,131,175,129,170,131,159,134,157,134,160,130,170,125,176,114,176,
102,173,103,172,108,171,111,163,115,156,116,149,117,142,116,136,115,129,115,124,115,120,115,115,117,
113,120,109,122,102,122,100,121,95,121,89,115,87,110,82,109,84,118,89,123,93,129,100,130,108,132,110,
133,110,136,107,138,105,140,95,138,86,141,79,149,77,155,81,162,90,165,97,167,99,171,109,171,107,161,
111,156,113,170,115,185,118,208,117,223,121,239,128,251,133,259,136,266,139,276,143,290,148,310,151,
332,155,348,156,353,153,366,149,379,147,394,146,399" VALUE s1

" 156,141,165,135,169,131,176,130,187,134,191,140,191,146,186,150,179,155,175,157,168,157,163,157,159,
157,158,164,159,175,159,181,157,191,154,197,153,205,153,210,152,212,147,215,146,218,143,220,132,220,
125,217,119,209,116,196,115,185,114,172,114,167,112,161,109,165,107,170,99,171,97,167,89,164,81,162,
77,155,81,148,87,140,96,138,105,141,110,136,111,126,113,129,118,117,128,114,137,115,146,114,155,115,
158,121,157,128,156,134,157,136,156,136" VALUE s2

s1 " {CRLF}" "" replace-str-
s2 " {CRLF}" "" replace-str-

: str-to-list ( s -- list )
   STR@ %[ START{ [CHAR] , byChar split DUP STR@ NUMBER 0= THROW %n }EMERGE ]% ;

s1 str-to-list VALUE list1
s2 str-to-list VALUE list2

: list-to-graph { list | graph data -- graph }
   Graph2D :new -> graph
   list length 2 / graph :points!
   list
   BEGIN
     DUP cdr empty? 0=
   WHILE
     DUP car DS>F
     cdr DUP car DS>F FNEGATE graph :point!
     cdr
   REPEAT
   DROP
   graph ;

: draw { plot2d | w }
   GLWindow :new -> w
    w :create
   S" connect the dots" w :setText
   w :maximize

   plot2d w :add
   plot2d :autoScale

   w :show
   w :run
   w :free ;

: main { l1 l2 | plot graph }
   GLPlot2D :new TO plot

   l1 list-to-graph TO graph
   Magenta graph <color @ :set
   graph plot :add

   l2 list-to-graph TO graph
   Yellow graph <color @ :set
   graph plot :add

   plot draw ;

list1 list2 main BYE

Отгадать - что же изображено на рисунке - оставим упражнением читателю :)


Задачка 10

Требуется определить длину 30-го элемента последовательности. Последовательность задана несколькими первыми элементами : (1), (1 1), (2 1), (1 2 1 1), (1 1 1 2 2 1),...
Алгоритм конструирования элементов - образно говоря - "что вижу, то пишу" : 1 - один один - 1 1 - две единицы - 2 1 - один два один один - 1 2 1 1 - один один один два два один - 1 1 1 2 2 1 - три один два два один один - итд.

Решение

Последовательность представим в виде списка. Слово sequence бежит по списку запоминая сколько одинаковых элементов подряд расположено, возвращает начало необработанной части списка, значение и счёт этих значений (cdr ( node -- next ), car ( node -- value )). Слово look&say компонует результат в новый список.

REQUIRE lst( ~ygrek/lib/list/ext.f
REQUIRE { lib/ext/locals.f

: sequence { lst | val cnt -- lst1 val cnt }
   lst empty? ABORT" assertion failed"
   lst car TO val
   1 TO cnt
   lst cdr
   BEGIN
    DUP empty? IF val cnt EXIT THEN
    DUP car val <> IF val cnt EXIT THEN
    cnt 1+ TO cnt
    cdr
   AGAIN ;

: look&say ( lst -- lst2 )
   %[
   BEGIN
    DUP empty? 0=
   WHILE
    sequence % %
   REPEAT
   DROP ]% ;

: morris ( n -- lst )
   lst( 1 % )lst
   SWAP 0 ?DO
    DUP
    look&say SWAP FREE-LIST
   LOOP ;

30 morris length .

Продолжение следует :)