fork download
copy 
  1. \ shpath.fs
  2.  
  3. 12      CONSTANT /NAME
  4. 2       CONSTANT /INDEX
  5. 10000   CONSTANT MAX-NODE
  6. 100000000 CONSTANT MAX-EDGE
  7. 100     CONSTANT MAX-REQUEST
  8.  
  9. $03FFF     CONSTANT INDEX-MASK
  10. $03FFFF    CONSTANT COST-MASK
  11. $0FFFFFFFF CONSTANT EDGE-INDEX-MASK
  12.  
  13.  
  14.  
  15. CREATE NAMES 0 , MAX-NODE /NAME * ALLOT
  16. CREATE NODES 0 , MAX-NODE /INDEX * ALLOT
  17. CREATE EDGES 0 , MAX-EDGE CELLS ALLOCATE THROW ,
  18. CREATE LINKS 0 , MAX-NODE CELLS ALLOT
  19. CREATE PATH  0 , MAX-NODE /INDEX * ALLOT
  20. CREATE HASH-TABLE 0 , MAX-NODE /INDEX * ALLOT
  21. CREATE BITSET MAX-NODE 8 / 1+ ALLOT
  22. CREATE PQUEUE 0 , MAX-NODE CELLS ALLOT
  23. CREATE PQUEUE-INDEX MAX-NODE 1+ /INDEX * ALLOT
  24. CREATE REQUESTS 0 , MAX-REQUEST CELLS ALLOT
  25.  
  26. : INITIALIZE
  27.     NODES OFF
  28.     LINKS OFF
  29.     EDGES OFF
  30.     NAMES OFF
  31.     HASH-TABLE OFF ;
  32.  
  33. : NODE^ ( index -- addr )
  34.     /INDEX * CELL+ NODES + ;
  35.  
  36. : NODE>EDGES ( index -- edge )
  37.     NODE^ W@ ;
  38.  
  39. : NAME^ ( index -- addr )
  40.     /NAME * NAMES CELL+ + ;
  41.  
  42. : ADD-NAME ( addr,count -- )
  43.     1 NAMES +!
  44.     NAMES @ NAME^ 2DUP
  45.     C! 1+ SWAP CMOVE ;
  46.  
  47. : LAST-NAME ( -- name )
  48.     NAMES @ ;
  49.  
  50. : LAST-NODE ( -- node )
  51.     NODES @ ;
  52.  
  53. : LAST-EDGE ( -- edge )
  54.     EDGES @ ;
  55.  
  56. : EDGE^ ( index -- addr )
  57.     ASSERT( DUP )
  58.     CELLS EDGES CELL+ @ + ;
  59.  
  60. : EDGE>DEST ( ecell -- index )
  61.     16383 AND ;
  62.  
  63. : EDGE>COST ( ecell -- cost )
  64.     14 RSHIFT 262143 AND ;
  65.  
  66. : EDGE>NEXT ( ecell -- index )
  67.     32 RSHIFT EDGE-INDEX-MASK AND ;
  68.  
  69. : ECELL ( link,cost,edge -- ecell) 
  70.     SWAP 14 LSHIFT OR
  71.     SWAP 32 LSHIFT OR ;
  72.  
  73. : ADD-EDGE ( link,cost,edge -- edge )
  74.     1 EDGES +!  ECELL
  75.     LAST-EDGE TUCK EDGE^ ! ;
  76.  
  77. : LAST-LINK ( -- link )
  78.     LINKS @ ;
  79.  
  80. : LINK^ ( key -- addr )
  81.     CELLS LINKS CELL+ + ;
  82.  
  83. : LINK>NODE ( lcell -- node )
  84.     INDEX-MASK AND ;
  85.  
  86. : LINK>NAME ( lcell -- name )
  87.     16 RSHIFT INDEX-MASK AND ;
  88.  
  89. : LINK>NEXT ( lcell -- link )
  90.     32 RSHIFT INDEX-MASK AND ;
  91.  
  92. : LCELL ( link,name,node -- lcell)
  93.     ROT 32 LSHIFT                ( name,node,link<<32 )
  94.     ROT 16 LSHIFT OR OR ;        ( node|link<<32|name<<16 )
  95.  
  96. : ADD-LINK ( link,name,node -- link' )
  97.     1 LINKS +!
  98.     LCELL
  99.     LAST-LINK TUCK LINK^ ! ;
  100.  
  101. : HASH-RECORD^ ( key -- addr )
  102.     /INDEX * HASH-TABLE + ;
  103.  
  104. : HASH-KEY ( addr,count -- key )
  105.     0 -ROT OVER + SWAP
  106.     DO 33 * I C@ + LOOP
  107.     MAX-NODE MOD ;
  108.  
  109. : NEW-NODE ( -- node )
  110.     1 NODES +!
  111.     0 LAST-NODE TUCK NODE^ W! ;
  112.  
  113. : INSERT-NODE ( addr,count -- )
  114.     2DUP ADD-NAME HASH-KEY HASH-RECORD^
  115.     DUP W@ LAST-NAME NEW-NODE ADD-LINK
  116.     SWAP W! ;
  117.  
  118. : FIND-NODE ( addr,count -- lcell,T|F)
  119.     FALSE -ROT
  120.     2DUP HASH-KEY HASH-RECORD^ W@     ( F,addr,count,link )
  121.     BEGIN
  122.         DUP IF LINK^ @ THEN           ( F,addr,count,lcell )
  123.         DUP WHILE
  124.             DUP >R LINK>NAME NAME^ COUNT
  125.             2OVER COMPARE 0= IF
  126.                 ROT DROP R> -ROT FALSE
  127.             ELSE
  128.                 R> LINK>NEXT
  129.             THEN
  130.     REPEAT DROP 2DROP ;
  131.  
  132. : PQUEUE^ ( index -- addr )
  133.     CELLS PQUEUE + ;
  134.  
  135. : PQUEUE-INDEX^ ( index -- addr )
  136.     /INDEX * PQUEUE-INDEX + ;
  137.  
  138. : PQUEUE-INDEX@ ( node -- index )
  139.     PQUEUE-INDEX^ W@ ;
  140.  
  141. : PQUEUE-INDEX! ( node,index -- )
  142.     SWAP PQUEUE-INDEX^ W! ;
  143.  
  144. : PQUEUE-INIT
  145.     PQUEUE OFF
  146.     PQUEUE-INDEX MAX-NODE 1+ /INDEX * ERASE ;
  147.  
  148. : QCELL ( node,cost -- qcell )
  149.     32 LSHIFT OR ;
  150.  
  151. : QCELL! ( qcell,index -- )
  152.     OVER INDEX-MASK AND OVER ( qcell,index,node,index )
  153.     PQUEUE-INDEX!
  154.     PQUEUE^ ! ;
  155.  
  156. : QCELL@ ( index -- qcell )
  157.     PQUEUE^ @ ;
  158.  
  159. : QCELL>NODE ( qcell -- node )
  160.     INDEX-MASK AND ;
  161.  
  162. : QCELL>COST ( qcell -- cost )
  163.     32 RSHIFT ;
  164.  
  165. : PQUEUE-COMPARE ( i,j -- n )
  166.     SWAP QCELL@ SWAP QCELL@ - ;
  167.  
  168. : PQUEUE-SWAP ( i,j -- )
  169.     OVER QCELL@ OVER QCELL@ ( i,j,icell,jcell )
  170.     SWAP ROT QCELL! SWAP QCELL! ;
  171.  
  172. : PQUEUE-SELECT-SMALLER ( i,j -- i|j )
  173.     2DUP PQUEUE-COMPARE 0< IF DROP ELSE NIP THEN ;
  174.  
  175. : SIFT-DOWN ( index )
  176.     BEGIN
  177.         DUP 2*
  178.         DUP PQUEUE @ <= WHILE
  179.         DUP PQUEUE @ < IF
  180.             DUP 1+ PQUEUE-SELECT-SMALLER
  181.         THEN
  182.         2DUP PQUEUE-COMPARE 0> IF
  183.             2DUP PQUEUE-SWAP NIP
  184.         ELSE
  185.             2DROP PQUEUE @
  186.         THEN
  187.     REPEAT 2DROP ;
  188.  
  189. : SIFT-UP ( index )
  190.     BEGIN DUP 1 > WHILE
  191.         DUP 2/
  192.         2DUP PQUEUE-COMPARE 0< IF
  193.             2DUP PQUEUE-SWAP
  194.         THEN
  195.         NIP
  196.     REPEAT DROP ;
  197.  
  198. : (PQUEUE-INSERT) ( node,cost -- )
  199.     1 PQUEUE +!
  200.     OVER PQUEUE @ PQUEUE-INDEX!
  201.     QCELL PQUEUE @ QCELL!
  202.     PQUEUE @ SIFT-UP ;
  203.  
  204. : (PQUEUE-UPDATE) ( node,cost,index -- )
  205.     OVER >R DUP QCELL@ QCELL>COST R> > IF
  206.         DUP 2SWAP QCELL ROT QCELL!
  207.         DUP SIFT-UP SIFT-DOWN
  208.     ELSE
  209.         DROP 2DROP
  210.     THEN ;
  211.  
  212. : PQUEUE-UPDATE ( node,cost -- )
  213.     OVER PQUEUE-INDEX@ ?DUP IF
  214.         (PQUEUE-UPDATE)
  215.     ELSE
  216.         (PQUEUE-INSERT)
  217.     THEN ;
  218.  
  219.  
  220. : LAST-QUEUE-CELL ( -- cell )
  221.     PQUEUE @ PQUEUE^ @ ;
  222.  
  223. : PQUEUE-EXTRACT-MIN ( -- node,cost )
  224.     1 QCELL@ DUP QCELL>NODE SWAP QCELL>COST
  225.     OVER 0 PQUEUE-INDEX!
  226.     LAST-QUEUE-CELL 1 QCELL!
  227.     -1 PQUEUE +!  1 SIFT-DOWN ;
  228.  
  229. : BITSET-INIT
  230.     BITSET MAX-NODE 8 / 1+ ERASE ;
  231.  
  232. : BITSET^ ( index -- mask,addr )
  233.     8 /MOD BITSET +
  234.     1 ROT LSHIFT SWAP ;
  235.  
  236. : BITSET-INCLUDE? ( index -- f )
  237.     BITSET^ C@ AND ;
  238.  
  239. : BITSET-INCLUDE! ( index -- )
  240.     BITSET^ TUCK C@ OR SWAP C! ;
  241.  
  242. VARIABLE TARGET-NODE
  243.  
  244. : FIND-PATH ( start,end -- cost )
  245.     TARGET-NODE !
  246.     PQUEUE-INIT
  247.     BITSET-INIT
  248.     0 PQUEUE-UPDATE
  249.     BEGIN
  250.         PQUEUE @ WHILE
  251.         PQUEUE-EXTRACT-MIN         \ node,cost
  252.         OVER BITSET-INCLUDE!
  253.         OVER TARGET-NODE @ <> IF   \ node,cost
  254.             SWAP NODE>EDGES        \ cost,edges
  255.             BEGIN DUP WHILE
  256.                 EDGE^ @            \ cost,ecell
  257.                 DUP EDGE>DEST      \ cost,ecell,dest
  258.                 OVER EDGE>COST     \ cost,ecell,dest,cost
  259.                 2>R OVER 2R> ROT + \ cost,ecell,dest,cost'
  260.                 OVER BITSET-INCLUDE? 0= IF
  261.                     PQUEUE-UPDATE
  262.                 ELSE
  263.                     2DROP
  264.                 THEN
  265.                 EDGE>NEXT         \ cost,edge
  266.             REPEAT
  267.             2DROP
  268.         ELSE
  269.             NIP
  270.             PQUEUE OFF            \ cost
  271.         THEN
  272.     REPEAT ;                      \ cost
  273.  
  274. : (STR-TOKENS) ( addr,count -- add1,c1,add2,c2,…,n )
  275.     0 FALSE 2SWAP
  276.     OVER + DUP >R SWAP
  277.     DO I C@ BL <> IF
  278.         DUP 0= IF
  279.             I ROT 1+
  280.             ROT DROP TRUE
  281.         THEN
  282.     ELSE
  283.         DUP IF
  284.             ROT I OVER -
  285.             2SWAP DROP FALSE
  286.     THEN THEN LOOP
  287.     R> SWAP
  288.     IF ROT TUCK - ROT ELSE DROP THEN ;
  289.  
  290. : STR-TOKENS ( addr,count -- add1,c1,add2,c2,…,n )
  291.     DUP IF (STR-TOKENS) ELSE NIP THEN ;
  292.  
  293. : STR>NUMBER ( addr,count -- n )
  294.     0 -ROT OVER + SWAP DO
  295.         I C@ [CHAR] 0 - 
  296.         SWAP 10 * +
  297.     LOOP ;
  298.  
  299. : REQUEST^ ( index -- addr )
  300.     CELLS REQUESTS + ;
  301.  
  302. 256 CONSTANT LINE-MAX
  303. CREATE LINE-BUFFER LINE-MAX ALLOT
  304.  
  305. VARIABLE INPUT-FILE
  306.  
  307. : READ-INPUT-LINE ( -- addr,count )
  308.     LINE-BUFFER LINE-MAX INPUT-FILE @
  309.     READ-LINE THROW DROP
  310.     LINE-BUFFER SWAP ;
  311.  
  312. : READ-NUMBER ( -- n )
  313.     READ-INPUT-LINE
  314.     STR-TOKENS ASSERT( 1 = )
  315.     STR>NUMBER ;
  316.  
  317. : READ-EDGES ( n -- )
  318.     0 DO
  319.         READ-INPUT-LINE                  ( addr,count )
  320.         STR-TOKENS                       ( add1,count1,add2,count2,2 )
  321.         ASSERT( 2 = )
  322.         STR>NUMBER -ROT STR>NUMBER       ( cost,dest )
  323.         LAST-NODE NODE^ DUP @            ( cost,dest,nodeAddr,edges )
  324.         2SWAP ADD-EDGE SWAP !
  325.     LOOP ;
  326.  
  327. : READ-NODE
  328.     READ-INPUT-LINE
  329.     STR-TOKENS ASSERT( 1 = )
  330.     INSERT-NODE
  331.     READ-NUMBER READ-EDGES ;
  332.  
  333. : READ-NODES
  334.     READ-NUMBER 0 DO READ-NODE LOOP ;
  335.  
  336. : READ-REQUEST
  337.     READ-INPUT-LINE
  338.     STR-TOKENS ASSERT( 2 = )
  339.     FIND-NODE LINK>NODE 32 LSHIFT -ROT
  340.     FIND-NODE LINK>NODE OR ;
  341.  
  342. : READ-REQUESTS
  343.     REQUESTS OFF
  344.     READ-NUMBER 0 DO
  345.         1 REQUESTS +!
  346.         READ-REQUEST
  347.         REQUESTS @ REQUEST^ !
  348.     LOOP ;
  349.  
  350. : READ-TEST-CASE
  351.     INITIALIZE READ-NODES READ-REQUESTS ;
  352.  
  353. : EXEC-REQUEST ( rcell -- )
  354.     DUP INDEX-MASK AND SWAP 32 RSHIFT
  355.     FIND-PATH . CR ;
  356.  
  357. : EXEC-REQUESTS
  358.     REQUESTS @ 1+ 1 DO
  359.         I REQUEST^ @ EXEC-REQUEST
  360.     LOOP ;
  361.  
  362. : PROCESS
  363.     READ-NUMBER 0 DO
  364.         READ-TEST-CASE
  365.         EXEC-REQUESTS
  366.     LOOP ;
  367.  
  368. : FREE-EDGES
  369.     EDGES CELL+ @ FREE THROW ;
  370.  
  371. STDIN INPUT-FILE !
  372. PROCESS
  373. FREE-EDGES BYE
  374.  
  375.  
Success #stdin #stdout 0.01s 5284KB
comments (?)
stdin
copy 
1
4
gdansk
2
2 100
3 300
bydgoszcz
3
1 100
3 100
4 400
torun
3
1 300
2 100
4 100
warszawa
2
2 400
3 100
2
gdansk warszawa
bydgoszcz warszawa
stdout
copy 
300 
200
https://ideone.com/TWPOC6
problem SHPATH, based on SPOJ submission 34219859 (FORTH), 2025-02-19 20:53:13
language:
Forth (gforth 0.7.3)
created:
2 days ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!