расширенные операторами стековые манипуляторы

вопрос

пирамидальная не требует памяти (почти)

dynamic-wind

Да, heapsort.
Один вариант вообще без доп. памяти, другой чуть быстрее (с меньшим количеством стравнений) и памятью на 1 элемент.
Нестабильна.
Время постоянное O(N * log N).

Ethereal

Ну хорошо, а тогда так :

Код:

\ Сортируется len>0 произвольных элементов с индексами 0..(len-1)
VECT @SWAP \ ( i j -- ) \ Поменять местами i-й сортируемый элемент с j-м
VECT @LESS \ ( i j -- flag ) \ Сравнить i-й сортируемый элемент с j-м
\ вернуть TRUE если i-й меньше и FALSE в противном случае

DECIMAL
: SORT ( +len -- ) \ Алгоритм сортировки расческой
  DUP
  BEGIN
    DUP 1 >
  WHILE
    BEGIN
      DUP 1 > IF 21449 26754 */ THEN
      2DUP - DUP 0 DO
        OVER I + I @LESS
        IF OVER I + I @SWAP DROP FALSE THEN
      LOOP
    UNTIL
  REPEAT 2DROP
;

Ethereal

dynamic-wind писал(а):

Да, heapsort.
Один вариант вообще без доп. памяти, другой чуть быстрее (с меньшим количеством стравнений) и памятью на 1 элемент.
Нестабильна.
Время постоянное O(N * log N).

Так исходник-то на Форте кидай уже.

dynamic-wind

Ethereal писал(а):

Так исходник-то на Форте кидай уже.

Я писал на С. На форте не пишу, только читаю.

А у фортерного профи кодирование займёт 5 минут :wink:

, такой там простой алгоритм.

Ethereal

Как работать, так все чатлане !

Ethereal

Код:

\ Сортируется len>0 произвольных элементов с индексами 0..(len-1)
VECT @SWAP \ ( i j -- ) \ Поменять местами i-й сортируемый элемент с j-м
VECT @LESS \ ( i j -- flag ) \ Сравнить i-й сортируемый элемент с j-м
\ вернуть TRUE если i-й меньше и FALSE в противном случае

0 VALUE [n]
: Sift  1+ DUP [n] < IF 2DUP @LESS IF NIP DUP THEN THEN  ;
: SiftDown ( n i -- n )
  OVER TO [n]
  BEGIN
    DUP DUP 2*
    Sift Sift DROP
    2DUP <>
  WHILE
    TUCK @SWAP
  REPEAT 2DROP
;
: SORT ( +len -- ) \ Алгоритм пирамидальной сортировки
  DUP 1 >
  IF
    0 OVER 2/ 1- DO I SiftDown -1 +LOOP
    BEGIN
      1- DUP
    WHILE
      DUP 0 @SWAP
      0 SiftDown
    REPEAT
  THEN DROP
;

Он тут вышел нереентерабельный. Его можно сделать и реентерабельным, изменив чуток, но тогда он корявее запишется.

Ethereal

Вот реентерабельный вариант :
<OBSOLETE>

dynamic-wind

VECT может и не мешают многопоточности, но их могут испортить из прерываний.

Если только не сохранять явным образом. :^)

вопрос

Ethereal писал(а):

Как работать, так все чатлане !

Никто не сомневается, что среди фортеров нет бездарей, бездарь на форт не "клюнет"

chess

Сделал смешанный синтаксис манипуляторов.
Односимвольные знаки операций из как раньше operations?
и произвольные операции в скобках []:

Код:

: operations? ( sym -- tf )
  CASE
  '+' OF +   0 ENDOF '-' OF -    0 ENDOF '*' OF *    0 ENDOF '/' OF /      0 ENDOF '%' OF MOD  0 ENDOF '_' OF NEGATE 0 ENDOF
  '|' OF OR  0 ENDOF '^' OF XOR  0 ENDOF '&' OF AND  0 ENDOF '~' OF INVERT 0 ENDOF
  '>' OF >   0 ENDOF '<' OF <    0 ENDOF '=' OF =    0 ENDOF
  '!' OF !   0 ENDOF '@' OF @    0 ENDOF
  'd' OF DUP 0 ENDOF 'x' OF DROP 0 ENDOF 'D' OF 2DUP 0 ENDOF 'X' OF 2DROP  0 ENDOF
1 ENDCASE ;
: SPDROP ( p*n n --)  $ 2 #A<< P+A DROP ;
: SPMOVE ( p*n addr n --) $ 4 B=aP D=@P L1: C=@B @D=C $ 4 Da $ 4 Ba A-- L1 J0<> 2DROP ;
: SPREV  ( p*n n -- p'*n) A-- D=P $ 2 #A<< A+D L1: B=@D C=@A @A=B @D=C $ 4 Da $ -4 Aa A=D? L1 J>= DROP ;
: NOTFOUND ( A U -- )
  2DUP 1 > >R C@ '0' - 1 10 WITHIN >R OVER 1+ C@ '\' = 2R> AND AND 0=
  IF   NOTFOUND EXIT
  ELSE u! a! 100 sp] 0 Lb! 0. beg! end! 0 f!
       ss( is u is a a C@ '0' - is Lb Lb SPREV sp Lb SPMOVE Lb SPDROP
           a u + a 2+ ?DO I C@
           CASE
             '[' OF 1 is f I 1+ is beg ENDOF
             ']' OF 0 is f I is end beg end beg - SFIND DROP EXECUTE ENDOF
           ENDCASE
           f 0= IF I C@ operations?
                   IF I C@ '0' - DUP 1 10 WITHIN
                      IF 1- CELLS sp + @ ELSE DROP THEN
                   THEN
                THEN LOOP )
     STATE @ IF a u SLIT, l' ss LIT, EXECUTE, ELSE a u ss THEN
  THEN ;

Код:

\EOF
1 1\11 . .
2 1\1d  . .
3 1\1[DUP] . .
2 3  2\12+  .
3 4  2\12[+]  .
2 15 2\12-[0<] .
1 2 3 5 4\12+[1+][2+]34*

: /str ( a u n -- a1 u1 )
  3\13+23- ;
S" 123456" 3 /str

spf тут: http://file.qip.ru/file/CC_z7QqS/spf419mals.html

Antender

Вот это уже стало гораздо интереснее.

Ethereal

dynamic-wind писал(а):

VECT может и не мешают многопоточности, но их могут испортить из прерываний.
Если только не сохранять явным образом. :^)

Ну хорошо, вот тебе совсем реентерабельно, но и более коряво из-за
необходимости выбирать токены swap и less со дна стека через PICK

Код:

: Sift ( less n i icurr inew-1 -- less n i icurr inew | less n i inew inew )
  1+ DUP 4 PICK ( n ) < IF 2DUP 6 PICK ( less ) EXECUTE IF NIP DUP THEN THEN
;
: SiftDown ( swap less n i -- swap less n )
  BEGIN
    DUP DUP 2*
    Sift Sift DROP
    2DUP <>
  WHILE
    TUCK 5 PICK ( swap ) EXECUTE
  REPEAT 2DROP
;
\ Сортируется len>0 произвольных элементов с индексами 0..(len-1)
\ Токен swap ( i j -- ) меняет местами i-й сортируемый элемент с j-м
\ Токен less ( i j -- flag ) сравнивает i-й сортируемый элемент с j-м,
\ возвращает TRUE если i-й меньше, и FALSE в противном случае
: SORT ( swap less +len -- ) \ Алгоритм пирамидальной сортировки
  DUP 1 >
  IF
    0 OVER 2/ 1- DO I SiftDown -1 +LOOP
    BEGIN
      1- DUP
    WHILE
      DUP 0 4 PICK ( swap ) EXECUTE
      0 SiftDown
    REPEAT
  THEN 2DROP DROP
;

\ Пример использования :
CREATE МАССИВ 7 , 5 , -1 , 0 , 7 , 11 , -3 , 9 , 6 , 4 ,
10 CONSTANT РАЗМЕР_МАССИВА
: #SWAP CELLS МАССИВ + >R CELLS МАССИВ + R@ @ SWAP DUP @ R> ! ! ;
: #LESS CELLS МАССИВ + @ >R CELLS МАССИВ + @ R> < ;
: ДАМП_МАССИВА РАЗМЕР_МАССИВА 0 DO МАССИВ I CELLS + @ . LOOP ;

' #SWAP ' #LESS РАЗМЕР_МАССИВА SORT
ДАМП_МАССИВА
BYE

З.Ы. Мало мало оптимизировал все алгоритмы сортировки, что выложил

вопрос

Ethereal писал(а):

Ну хорошо, вот тебе совсем реентерабельно, но

вот это, кстати, и есть работа над библиотекой...
казалось бы алгоритм есть, но что-то не так и вот ещё раз 7 таких претензий и будет кандидат на библиотеку

Ethereal

Надо-же. Алго пирамидальной сортировки ещё шлифанулся.
2DUP и NIP удачно заменились на единственный TUCK.
... И еще шлифанулся ... как всегда уминать алго ногами можно долго ...
И еще ...

расширенные операторами стековые манипуляторы

Кто сейчас на конференции