\ qpt.txt for Chris Jakeman  Leo Wong 4 April 02003 fyj +
\ Query periodic table. Uses allelements.xml from:
\   http://www.ibiblio.org/xml/examples/periodic_table/
\ Requires floating point words and a separate floating point stack
\ Output is sorted -- assumes equal units (haven't checked)
\ See usage examples at the end of this file

include from.txt

from XMLtree.txt

\ For contents of tags: 0=string, 1=integer, 2=float
linked Tags
: Tag,  ( -- )  Tags link <next> >n ,  <next> string, ;
many: Tag,
 0  NAME
 2  ATOMIC_WEIGHT
 1  ATOMIC_NUMBER
 0  OXIDATION_STATES
 2  BOILING_POINT
 0  SYMBOL
 2  DENSITY
 0  ELECTRON_CONFIGURATION
 2  ELECTRONEGATIVITY
 2  ATOMIC_RADIUS
 2  ATOMIC_VOLUME
 2  SPECIFIC_HEAT_CAPACITY
 2  IONIZATION_POTENTIAL
 2  THERMAL_CONDUCTIVITY
 2  MELTING_POINT
 2  COVALENT_RADIUS
 2  HEAT_OF_VAPORIZATION
 2  HEAT_OF_FUSION 
 0  ATOM ;

CREATE TargetTag 84 CHARS ALLOT
CREATE Sarg1 84 CHARS ALLOT  CREATE Sarg2 84 CHARS ALLOT
VARIABLE Narg1               VARIABLE Narg2
FVARIABLE Farg1              FVARIABLE Farg2

\ Check if target is a category; return datatype of contents
:NONAME  >data CELL+ ; IS >comp
: ?Target  ( -- datatype )
   TargetTag COUNT Tags inlist? NIP NIP ?DUP
   IF  CELL+ @ EXIT THEN
   CR TargetTag count TYPE SPACE  ." isn't an attribute. " ABORT ;

DEFER do-content  ( a u -- )  \ What to do with XML content 
\ String comparison to length of spec
: (Strings)  ( a u -- -1|0|1 )  DROP Sarg1 COUNT TUCK icompare ;
: String=  ( a u -- flag )  (Strings) 0= ;
: String>  ( a u -- flag )  (Strings) 0> ;
: String<  ( a u -- flag )  (Strings) 0< ;
: String><  ( a u -- flag)
   OVER >R (Strings) 0< 0= R> Sarg2 COUNT TUCK icompare 0> 0= AND ;
: (Ints)  ( a u -- n1 n2 )  >n Narg1 @ ;
: Int=  ( a u -- flag )  (Ints) =  ;
: Int<  ( a u -- flag )  (Ints) < ;
: Int>  ( a u -- flag )  (Ints) > ;
: Int><  ( a u -- flag)  (Ints) Narg2 @ 1+ WITHIN ;
: F>=  ( f: r1 r2 -- -1|0|1 ) F< 0= ;
: F<=  ( f: r1 r2 -- -1|0|1 ) FSWAP F>= ;
: >f ( a u -- )  ( f: -- r )  trim >FLOAT 0= Abort" >f failed " ;
: (Floats)  ( a u -- )  ( f: -- r1 r2 )  >f Farg1 F@ ;
: Float=  ( a u -- flag ) (Floats) F=  ;
: Float>  ( a u -- flag ) (Floats) FSWAP F< ;
: Float<  ( a u -- flag ) (Floats) F< ;
: Float><  ( a u -- flag )  >f FDUP Farg1 F@ f>= Farg2 F@ f<= AND ;

FALSE VALUE Get-Name
FALSE VALUE Get-Content
FALSE VALUE Curname
: >TagType  ( node -- a )  2 CELLS + ;
: >Content  ( node -- a )  3 CELLS + ;
: <tag>  ( node -- )
   >Content @+
   2DUP S" NAME" COMPARE 0= IF TRUE TO Get-Name THEN
   TargetTag COUNT COMPARE 0= IF TRUE TO Get-Content THEN ;
   
: .Data  ( ca u -- )  CR Curname @+ TYPE SPACE TYPE ;
: .Stop ( node -- ) CELL+ COUNT 2DUP CR TYPE SPACE CHARS + COUNT TYPE ;
: .Top  ( node -- ) CELL+ DUP CR ? SPACE CELL+ COUNT TYPE ;
: .Ftop  ( node -- )
    CELL+ FALIGNED DUP F@ CR F. SPACE FLOAT+ COUNT TYPE ;

linked Stop
: Sdata, Stop ssadd Curname @+ string, ;
: Data,  >n Stop sadd Curname @+ string, ;
: Fdata, >f Stop fsadd Curname @+ string, ;

DEFER xData
: xTags  ( node -- )
    DUP >TagType @ DUP
    tag = IF DROP <tag> ELSE
    content = IF DUP 
       Get-Name IF >Content TO Curname FALSE TO get-name
       ELSE DROP THEN
       Get-Content IF >Content @+ 2DUP Do-Content
         IF xData ELSE 2DROP THEN
         FALSE TO Get-Content
       ELSE DROP THEN
    ELSE DROP THEN THEN ;

linked top  ' top IS XMLtree
tree-xml xml\allelements.xml

: "Tag"  ( a u -- )  \ Replace spaces with _
   2DUP supper
   0 ?DO DUP C@ BL = IF [CHAR] _ OVER C! THEN CHAR+ LOOP DROP ;
: place-target  ( ca1 u1 ca2 u2 -- ca3 u3 ) 
   TUCK 2>R - trim 2DUP "Tag" TargetTag place 2R> 2 /STRING trim ; 
: comp?  ( ca1 u2 -- ca2 u2 )  \ pt <argument string>
   2DUP S" EQ" SEARCH IF place-target 0 EXIT THEN 
        S" GT" SEARCH IF place-target 1 EXIT THEN
        S" LT" SEARCH IF place-target 2 EXIT THEN 
        S" BT" SEARCH IF place-target 3 EXIT THEN ;

: (ss) word> Sarg1 place ;
:NONAME  (ss) ['] String= ;
:NONAME  (ss) ['] String> ;
:NONAME  (ss) ['] String< ;
:NONAME  (ss) word> Sarg2 place ['] String>< ;
: (is)  word> >n  Narg1 ! ;
:NONAME  (is) ['] Int= ;
:NONAME  (is) ['] Int> ;
:NONAME  (is) ['] Int< ; 
:NONAME  (is) word> >n Narg2 ! ['] Int>< ;
: (fs) word> >f Farg1 F! ;
:NONAME (fs) ['] Float= ;
:NONAME (fs) ['] Float> ;
:NONAME (fs) ['] Float< ;
:NONAME (fs) word> >f Farg2 F! ['] Float>< ;
CREATE doers 12 ,s
: >do-content  ( ca u comparison datatype )
   4 * + cells doers + @ execute is do-content ;
: qpt ( -- ) 
   ['] xTags is xnode  ['] .data is xData
   0 PARSE 2DUP supper comp?  ?Target >do-content 2DROP top xlist CR ;
: ?sort  ( datatype -- )
    CASE 0 OF ['] Sdata, ENDOF
         1 OF ['] Data,  ENDOF
              ['] Fdata,
         SWAP ENDCASE IS xData ;
: ?top  ( datatype -- )
    CASE  0 OF ['] .Stop  ENDOF
          1 OF ['] .Top   ENDOF
               ['] .Ftop      
         SWAP ENDCASE IS xnode ;
: sqpt  ( -- )
   HERE  ['] xTags IS xnode ['] Fdata, IS xData  Stop 0 OVER 2!
   0 PARSE 2DUP supper comp? ?Target >R 
   R@ ?sort R@  >do-content  2DROP top xlist 
   R> ?top Stop xlist CR  HERE - ALLOT ;
: find  ( -- )  sqpt ;
\ Usage: find <query name> eq|gt|lt|bt arg1 [arg2]
\ Query on:
\ NAME , ATOMIC WEIGHT,  ATOMIC NUMBER , OXIDATION STATES ,
\ BOILING POINT , SYMBOL , DENSITY , ELECTRON CONFIGURATION ,
\ ELECTRONEGATIVITY , ATOMIC RADIUS , ATOMIC VOLUME ,
\ SPECIFIC HEAT CAPACITY , IONIZATION POTENTIAL ,
\ THERMAL CONDUCTIVITY ,  MELTING POINT , COVALENT RADIUS ,
\ HEAT OF VAPORIZATION ,  HEAT OF FUSION
\   Include one operator: eq | gt | lt | bt
\   bt requires two args
\   Best not to use eq with floats
\   String compares are insensitive and to length of arg(s)
\ Usage examples:
\   find symbol eq a
\   find atomic number lt 10
\   find density bt 10.0 12.0