Category : Files from Magazines
Archive   : DDJ8705.ZIP
Filename : SHAMMLST.LST

þ2«@<MMMMMÀÀ

MODULE Regress

! Simple linear regression module

PUBLIC Slope, Intercept, Rsqr ! Global variables

PRIVATE Mean, Sdev ! Routines local to module only

DECLARE DEF Mean, Sdev

SHARE Sum, SumX, SumX2, SumY, SumY2, SumXY ! static local variable

!----------------- Initialize module ------------------
CALL InitializeSum

!----------------- module routine definitions ----------

def Missing = -1.0E+200

sub InitializeSum
! Set statistical summations to zero
let Sum, SumX, SumX2 = 0
let SumY, SumY2, SumXY = 0
let Slope, Intercept, Rsqr = Missing

end sub

sub AcumData(X(), Y(), NData)
! Subroutine to accumulate stat summations

FOR I = 1 TO NData
let Xt = X(I)
let Yt = Y(I)

let Sum = Sum + 1
let SumX = SumX + Xt
let SumY = SumY + Yt
let SumX2 = SumX2 + Xt * Xt
let SumY2 = SumY2 + Yt * Yt
let SumXY = SumXY + Xt * Yt
NEXT I

end sub

!--------- define internal functions ----------
def Mean(A,B) = A / B
def Sdev(Sum2, Sum, N) = SQR((Sum2 - Sum^2/N)/(N-1))

sub LineFit

let MeanX = Mean(SumX,Sum)
let MeanY = Mean(SumY,Sum)
let SdevX = Sdev(SumX2,SumX,Sum)
let SdevY = Sdev(SumY2,SumY,Sum)
! calculate sought regression results
let Slope = (SumXY - MeanX * MeanY * Sum) / SdevX^2 / (Sum - 1)
let Intercept = MeanY - Slope * MeanX
let Rsqr = (SdevX / SdevY * Slope)^2

end sub

END MODULE


Example 1: True BASIC source code for linear regression module






! PROGRAM Regress demonstrates calling module "regress"

OPTION BASE 1

!--------------- Module declarations -----------
Library "REGRESS.MDL"
DECLARE PUBLIC Slope, Intercept, Rsqr

DIM X(100), Y(100)

let MAX_DATA = 100

CLEAR ! clear screen
DO
INPUT PROMPT "Enter number of data points " : NData
PRINT
LOOP UNTIL (NData > 2) AND (NData <= MAX_DATA)

FOR I = 1 TO NData
PRINT "For data point # ";I
INPUT PROMPT " enter X " : X(I)
INPUT PROMPT " enter Y " : Y(I)
PRINT
NEXT I

Call InitializeSum ! initialize stat summations

Call AcumData(X, Y, NData)

Call LineFit

CLEAR
PRINT USING "Rsqr = #.######" : Rsqr
PRINT USING "Slope = +#.#####^^^^" : Slope
PRINT USING "Intercept = +#.#####^^^^" : Intercept

END


Example 2: True BASIC source code for application program using the regression module in Example 1




MODULE Sort

PUBLIC Item$(100), NData ! Global array and variable

PRIVATE Set_Up, ShellSort ! Routines local to the module

DECLARE DEF Search_Index

SHARE Ptr(100), Table(26), FALSE, TRUE, HI_CHAR, MAX_DATA

!------------------ Module initialization ----------
let TRUE = 1
let FALSE = 0
let HI_CHAR = 26
let MAX_DATA = 100

!---------------- Routines definition ----------------

sub Set_Up
! Make sure that the arrays have enough space
IF NData > MAX_DATA THEN ! adjust array sizes if needed
MAT REDIM Item$(NData)
MAT REDIM Ptr(NData)
END IF

end sub


!-----------------------------------------------------

sub Set_Index
! Build index table

MAT Table = ZER ! Initialize array

FOR Char_Index = 1 TO HI_CHAR
let C$ = CHR$(64 + Char_Index) ! --> 'A' to 'Z'
IF Char_Index = 1 THEN ! Start searching at the beginning
let Index = 1
ELSE
! Seach backwards
let Index = 1 ! assume worst case as default
let J = Char_Index ! use J as copy of index I
DO WHILE J > 1
IF Table(J-1) > 0 THEN ! found good 'last index'
let Index = Table(J-1)
let J = 0 ! zero to exit loop
ELSE
let J = J - 1 ! one step backward
END IF
LOOP
END IF

let Found = FALSE

DO WHILE (Index <= NData) AND (Found = FALSE)
let J = Ptr(Index)
let S$ = Item$(J)[1:1]
IF S$ = C$ THEN ! Match found
let Found = TRUE
let Table(Char_Index) = Index ! store entry index
ELSE
let Index = Index + 1 ! increment index for more search
END IF
LOOP
NEXT Char_Index

end sub

!-----------------------------------------------------

sub ShellSort
! Sort the pointers and keep Item$() unchanged

! Initialize pointers
FOR I = 1 TO NData
let Ptr(I) = I
NEXT I

! Start the Shell sort
let Offset = NData
DO WHILE OFFSET > 1
let Offset = INT(Offset / 2)
DO
let InOrder = TRUE
FOR J = 1 TO (NData - Offset)
let I = J + Offset
IF Item$(Ptr(I)) < Item$(Ptr(J)) THEN
let Tempo = Ptr(I)
let Ptr(I) = Ptr(J)
let Ptr(J) = Tempo
let InOrder = FALSE
END IF
NEXT J
LOOP UNTIL InOrder = TRUE
LOOP

end sub

!-----------------------------------------------------

sub Sort_and_Index

CALL Set_Index
CALL ShellSort

end sub

!-----------------------------------------------------

def Search_Index(Datum$, Occur)
! Search for the n th Occur(ance) of Datum$ in array Item$()
! Use index table for faster search

let S$ = UCASE$(Datum$[1:1]) ! pick first character in Datum$
let Index = Ord(S$) - 64 ! Get index for search table
let Table_Index = Table(Index) ! get index entry
let Occurance = ABS(INT(Occur)) ! assign Occur to local copy

IF Table_Index > 0 THEN ! Yes there is an entry!
let Found = FALSE
let More_Loop = TRUE

DO WHILE (Table_Index <= NData) AND (Found = FALSE) AND (More_Loop = TRUE)
let J = Ptr(Table_Index) ! store pointer in J
IF Datum$ = Item$(J) THEN ! found a match
let Occurance = Occurance - 1 ! Decrement occurance count
IF Occurance < 1 THEN ! Yes, this the one we want!
let Found = TRUE
let Search_Index = Ptr(Table_Index)
ELSE ! No! keep searching!
let Table_Index = Table_Index + 1
END IF
ELSE ! Should we keep searching?
IF S$ = Item$(J)[1:1] THEN ! Yes
let Table_Index = Table_Index + 1
ELSE ! No, we are have gone too far and not found a match
let More_Loop = FALSE ! stop looping
let Search_Index = 0 ! search has failed
END IF
END IF
LOOP

ELSE
let Search_Index = 0
END IF

end def

END MODULE


Example 3: True BASIC source code for module Sort


! PROGRAM Sort_and_Search

Library "Sort.mdl"
DECLARE DEF Search_Index
DECLARE PUBLIC Item$(), NData

CLEAR

let NData = 0
! Count items in DATA statements
DO WHILE MORE DATA
let NData = NData + 1
READ Dummy$ ! use dummy variable
LOOP

RESTORE ! DATA counter
CALL Set_Up ! Adjust Item$() if needed

! Read DATA into Item$(), now that we have enough space
FOR I = 1 TO NData
READ Item$(I)
NEXT I

CALL Sort_and_Index ! Sort and prepare index table

let Occur = 1 ! Search for first occurance
DO
INPUT PROMPT "Enter sought keyword or [Q] to exit ? " : Search$
let Search$ = UCASE$(Search$)
IF Search$[1:1] <> "Q" THEN
PRINT Search$;" is item number ";Search_Index(Search$, Occur)
PRINT
ELSE
PRINT
PRINT "PRESS ANY KEY TO EXIT "
END IF
LOOP UNTIL Search$[1:1] = "Q"

! DATA statements contain a list of Pascal keywords
DATA WRITE, READ, ASSIGN, SEEK, HI, LO, SQRT
DATA SQR, TAN, SIN, COS
DATA IFF, THEN, ELSE, WHILE, REPEAT, BEGIN
DATA FUNCTION, VAR, TYPE
DATA RECORD, SET, FOR, PROCEDURE, PROGRAM

END


Example 4: True BASIC source code for application program using
module Sort, shown in Example 3


[1:1] = "Q"

! DATA statements contain a list of Pascal keywords€³wòsØo <k}g¯cÑ_2[@Wz&

.œ€Word Rescue²€€€€€€€€€ €ÿÿ‚ÿÿ‘ÿÿ’ÿÿ´ÿÿµÿÿæÿÿçÿÿ
ÿÿ
ÿÿ
2ÿÿ
3ÿÿ
vÿÿ
wÿÿ
¯ÿÿ
Âÿÿ
Ãÿÿ
üÿÿ
ýÿÿÿÿ€ÿÿ(ÿÿMÿÿfÿÿÿÿ¦ÿÿ§ÿÿ°ÿÿ±ÿÿÏÿÿúÿÿûÿÿÿÿÿÿ0ÿÿ1ÿÿFÿÿ^ÿÿvÿÿ•ÿÿ€•´ÿÿÓÿÿÚÿÿÛÿÿãÿÿäÿÿÿÿ*ÿÿeÿÿfÿÿrÿÿsÿÿŽÿÿ©ÿÿÊÿÿëÿÿÿÿQÿÿwÿÿœÿÿ€œÿÿ¥ÿÿ¦ÿÿ±ÿÿ²ÿÿ³ÿÿòÿÿóÿÿôÿÿõÿÿöÿÿ÷ÿÿøÿÿ0ÿÿ1ÿÿ?ÿÿ@ÿÿqÿÿ‡ÿÿ­ÿÿ€­®ÿÿÁÿÿÂÿÿÕÿÿÖÿÿëÿÿîÿÿ%ÿÿ.ÿÿ]ÿÿ^ÿÿqÿÿÿÿ´ÿÿÙÿÿáÿÿèÿÿéÿÿÿÿÿÿ€5ÿÿ6ÿÿCÿÿDÿÿJÿÿoÿÿžÿÿÑÿÿÒÿÿÖÿÿ×ÿÿØÿÿ <ÿÿ =ÿÿ >ÿÿ ?ÿÿ @ÿÿ Lÿÿ Mÿÿ ‚ÿÿ€ ‚ ƒÿÿ ¼ÿÿ ½ÿÿ Öÿÿ ×ÿÿ
ÿÿ
ÿÿ
Gÿÿ
Tÿÿ
bÿÿ
sÿÿ
†ÿÿ
‡ÿÿ
¾ÿÿ
¿ÿÿ
Êÿÿ
øÿÿ0ÿÿJÿÿbÿÿ€biÿÿjÿÿrÿÿsÿÿªÿÿ«ÿÿ¹ÿÿÍÿÿÎÿÿñÿÿòÿÿ ÿÿ Dÿÿ ‚ÿÿ ˜ÿÿ ¢ÿÿ ¼ÿÿ ñÿÿ
'ÿÿ
>ÿÿ€
>
{ÿÿ
¢ÿÿ
Ðÿÿ
âÿÿÿÿ(ÿÿ5ÿÿ@ÿÿAÿÿWÿÿXÿÿŠÿÿ¥ÿÿÄÿÿêÿÿÿÿEÿÿSÿÿ—ÿÿ§ÿÿ€§°ÿÿÀÿÿÁÿÿÉÿÿÊÿÿ
ÿÿÿÿÿÿ?ÿÿCÿÿYÿÿlÿÿÿÿ†ÿÿ‡ÿÿžÿÿ±ÿÿÅÿÿæÿÿíÿÿ€íÿÿ.ÿÿMÿÿ€ÿÿ£ÿÿÇÿÿêÿÿÿÿ"ÿÿ1ÿÿOÿÿTÿÿUÿÿ]ÿÿ^ÿÿ•ÿÿ–ÿÿ©ÿÿªÿÿ¹ÿÿ€¹ÈÿÿËÿÿÓÿÿÔÿÿÿÿ ÿÿ,ÿÿiÿÿÿÿŽÿÿÌÿÿÿÿ3ÿÿpÿÿqÿÿ¢ÿÿ¸ÿÿÑÿÿÖÿÿ%ÿÿ€%[ÿÿÿÿÓÿÿÿÿ3ÿÿgÿÿŽÿÿÀÿÿÔÿÿýÿÿ+ÿÿ]ÿÿ£ÿÿØÿÿÿÿ&ÿÿ5ÿÿ>ÿÿ?ÿÿEÿÿ€E^ÿÿfÿÿgÿÿoÿÿpÿÿ{ÿÿ|ÿÿ}ÿÿ¯ÿÿ°ÿÿ±ÿÿËÿÿÌÿÿßÿÿøÿÿÿÿÿÿÿÿÿÿ,ÿÿ€,Mÿÿ`ÿÿzÿÿŸÿÿ¤ÿÿ¥ÿÿ¼ÿÿãÿÿäÿÿÿÿ/ÿÿ@ÿÿGÿÿHÿÿ{ÿÿ|ÿÿ§ÿÿªÿÿíÿÿÿÿ€-ÿÿrÿÿÿÿ‡ÿÿ”ÿÿºÿÿÄÿÿâÿÿãÿÿÿÿDÿÿ\ÿÿ‡ÿÿ ÿÿÊÿÿËÿÿÏÿÿÐÿÿÑÿÿÿÿ€2ÿÿ3ÿÿ4ÿÿAÿÿ”ÿÿºÿÿÄÿÿâÿÿãÿÿÿÿDÿÿ\ÿÿ‡ÿÿ ÿÿÊÿÿËÿÿÏÿÿÐÿÿÑÿÿÿÿ€