%%HP: T(3)A(D)F(,);
DIR
@ Programmpaket zur Berechnung der Querschnittswerte eines statischen Querschnitts.
@ Beschreibung im PDF-Dokument QSW.pdf.
  CPOLY
  \<< { } 'POLYGON' STO
  \>>
  KOOIN
  \<< \->V2 POLYGON SWAP + 'POLYGON' STO
  \>>
  AREA
  \<< 'POLYGON' VTYPE
    IF -1, ==
    THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON
  nicht
   gefunden!" MSGBOX
    ELSE POLYGON BYTES SWAP DROP
      IF 90, <
      THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON Fehler!" MSGBOX
      ELSE POLYGON DUP HEAD + 2,
        \<< CROSS 2, /
        \>> DOSUBS
        \<< +
        \>> STREAM V\-> + +
      END
    END
  \>>
  CALC
  \<< RCLF { -20, -20, -21, -31, -95, } CF { -2, -3, -22, -90, -103, -105, } SF DEG RECT DEC 'POLYGON' VTYPE
    IF -1, ==
    THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD " POLYGON
  nicht 
   gefunden!" MSGBOX
    ELSE POLYGON BYTES SWAP DROP
      IF 90, <
      THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON Fehler!" MSGBOX
      ELSE POLYGON DUP HEAD + DUP DUP DUP 2,
        \<< CROSS 2, /
        \>> DOSUBS 1,
        \<< V\-> + +
        \>> DOLIST DUP
        \<< +
        \>> STREAM 'A' STO
        IF A 0, ==
        THEN 2000, ,1 BEEP 1000, ,1 BEEP 2000, ,1 BEEP "      A=0!
 Keine 
  Berechnung!" MSGBOX DROP DROP DROP DROP 'A' PURGE
        ELSE A
          IF 0, <
          THEN 2000, ,1 BEEP 1000, ,1 BEEP 2000, ,1 BEEP "Umlaufsinn
 nicht positiv!
Werte negativ!" MSGBOX
          END SWAP 2,
          \<< + 3, /
          \>> DOSUBS
          \<< *
          \>> DOLIST
          \<< +
          \>> STREAM A / V\-> 'ys' STO 'xs' STO 2,
          \<< V\-> ROT V\-> \-> x2 y2 x1 y1
            \<< y1 y2 + SQ y1 y2 * - x1 y2 * x2 y1 * - *
            \>>
          \>> DOSUBS
          \<< +
          \>> STREAM 12, / DUP 'Ix' STO A ys SQ * - 'Ixs' STO DUP 2,
          \<< V\-> ROT V\-> \-> x2 y2 x1 y1
            \<< x1 x2 + SQ x1 x2 * - x1 y2 * x2 y1 * - *
            \>>
          \>> DOSUBS
          \<< +
          \>> STREAM 12, / DUP 'Iy' STO A xs SQ * - 'Iys' STO 2,
          \<< V\-> ROT V\-> \-> x2 y2 x1 y1
            \<< x1 x2 + y1 y2 + * x1 y2 * x2 y1 * + 2, / - x1 y2 * x2 y1 * - *
            \>>
          \>> DOSUBS
          \<< +
          \>> STREAM 12, / DUP 'Ixy' STO A xs ys * * - 'Ixys' STO
          IF Ixys 0, ==
          THEN 0,
          ELSE 2, Ixys * Iys Ixs - / ATAN 2, /
          END '\Gb\^o' STO Ixs Iys - 2, / \Gb\^o 2, * COS * Ixys \Gb\^o 2, * SIN * - DUP Ixs Iys + 2, / + 'Iu' STO Ixs Iys + 2, / SWAP - 'Iv' STO Iv ABS Iu ABS
          IF <
          THEN Iv ABS A ABS / \v/
          ELSE Iu ABS A ABS / \v/
          END 'imin' STO
          \<< { DEL A xs ys Ix Iy Ixy Ixs Iys Ixys Iv Iu \Gb\^o imin } PURGE
          \>> 'DEL' STO { DEL A xs ys Ix Iy Ixy Ixs Iys Ixys Iu Iv \Gb\^o imin } ORDER
        END
      END
    END STOF
  \>>
  RESULTS
  \<< RCLF 'Flagsave' STO { -20, -20, -21, -31, -95, } CF { -2, -3, -22, -90, -103, -105, } SF DEG RECT DEC
    \<< { POLYGON A xs ys Ix Iy Ixy Ixs Iys Ixys Iu Iv \Gb\^o imin } DUP VTYPE SORT HEAD
      IF -1, ==
      THEN CLLCD 1000, ,1 BEEP "Keine 
  Variablen!" MSGBOX "    Keine Werte!"
      ELSE "       Resultate"
      END
    \>> EVAL CLLCD SWAP DUP
    \<< EVAL
    \>> DOLIST SWAP
    \<< \->TAG
    \>> DOLIST 1, CHOOSE DROP Flagsave STOF 'Flagsave' PURGE
  \>>
  QPLOT
  \<< 'POLYGON' VTYPE
    IF -1, ==
    THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON
  nicht
   gefunden!" MSGBOX
    ELSE POLYGON BYTES SWAP DROP
      IF 62, <
      THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON Fehler!
Kein Dreieck!" MSGBOX
      ELSE POLYGON 1,
        \<< V\-> DROP
        \>> DOSUBS SORT DUP HEAD SWAP REVLIST HEAD POLYGON 1,
        \<< V\-> SWAP DROP
        \>> DOSUBS SORT DUP HEAD SWAP REVLIST HEAD ROT SWAP \->V2 'Vmax' STO \->V2 'Vmin' STO Vmax Vmin - ABS
        IF 0, ==
        THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP "Plotten des
 POLYGONs
  nicht 
   m\246glich!" CLLCD MSGBOX { Vmin Vmax } PURGE
        ELSE Vmax Vmin - V\-> \-> xd yd
          \<< xd yd / ABS 122, 55, /
            IF >
            THEN xd ABS 12,2 /
            ELSE yd ABS 5,5 /
            END
          \>> Vmax Vmin + 2, / POLYGON SWAP - SWAP / ERASE { # 0d # 0d } PVIEW PICT { # 2d # 2d } "QSW" 1, \->GROB REPL DUP HEAD + 2,
          \<< V\-> R\->C SWAP V\-> R\->C SWAP LINE
          \>> DOSUBS 7, FREEZE { PPAR Vmin Vmax } PURGE
        END
      END
    END
  \>>
  QPLO
  \<< 'POLYGON' VTYPE
    IF -1, ==
    THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON
  nicht
   gefunden!" MSGBOX
    ELSE POLYGON BYTES SWAP DROP
      IF 62, <
      THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP CLLCD "POLYGON Fehler!
Kein Dreieck!" MSGBOX
      ELSE POLYGON 1,
        \<< V\-> DROP
        \>> DOSUBS SORT DUP HEAD SWAP REVLIST HEAD POLYGON 1,
        \<< V\-> SWAP DROP
        \>> DOSUBS SORT DUP HEAD SWAP REVLIST HEAD ROT SWAP \->V2 'Vmax' STO \->V2 'Vmin' STO Vmax Vmin - ABS
        IF 0, ==
        THEN 3000, ,1 BEEP 2000, ,1 BEEP 3000, ,1 BEEP "Plotten des
 POLYGONs
  nicht 
   m\246glich!" CLLCD MSGBOX { Vmin Vmax } PURGE
        ELSE Vmax Vmin - V\-> \-> xd yd
          \<< xd yd / ABS 122, 55, /
            IF >
            THEN xd ABS 12,2 /
            ELSE yd ABS 5,5 /
            END
          \>> Vmax Vmin + 2, / POLYGON SWAP - SWAP / ERASE { # 0d # 0d } PVIEW PICT { # 2d # 2d } "QSW" 1, \->GROB REPL 2,
          \<< V\-> R\->C SWAP V\-> R\->C SWAP LINE
          \>> DOSUBS 7, FREEZE { PPAR Vmin Vmax } PURGE
        END
      END
    END
  \>>
  POLYGON { }
  BILD
  \<< { } PVIEW
  \>>
  QSich
  DIR
    POLYGON { [ 3, 5, ] [ 2, 4, ] [ 3, 2, ] [ 8, 3, ] [ 13, 2, ] [ 16, 10, ] [ 13, 9, ] [ 11, 5, ] [ 10, 6, ] }
    UMFKOO
    \<< POLYGON DUP HEAD + 'STRZUG' STO
    \>>
    UMFANG
    \<< STRZUG 2,
      \<< - ABS
      \>> DOSUBS
      \<< +
      \>> STREAM
    \>>
  END
END