/* This file contains procedures for packing and unpacking strings and vectors. */ /* Copyright (c) 2003 by R. A. Vowels. Date written: 10 December 2003. */ /* All rights reserved. */ DECLARE PACK GENERIC ( PACK4 WHEN ((*,*), (*,*) BIT, (*)), PACK3 WHEN ((*), (*) BIT, (*)), PACK2 WHEN ((*) CHARACTER, (*) BIT), PACKS WHEN (CHARACTER, CHARACTER) ); /* Note that PACKS is a function, while PACK2 and PACK3 are subroutines. */ /* This function procedure removes all characters from string Text that */ /* are in string S. The simplest use is to remove a given character */ /* (such as a blank) from Text. */ /* e.g., Text = 'The quick brown fox jumps over the lazy dog', ' '); */ /* PACK (Text, ' '); produces: */ /* 'Thequickbrownfoxjumpsoverthelazydog' */ PACKS: PROCEDURE (Text, S) OPTIONS (REORDER) RETURNS (CHARACTER(32767) VARYING); DECLARE (Text CHARACTER (*), S CHARACTER (*)) NONASSIGNABLE; DECLARE Out CHARACTER (LENGTH(Text)); DECLARE (J, K) FIXED BINARY(31); IF LENGTH(S) = 0 THEN RETURN (Text); IF LENGTH(S) = 1 THEN /* S is a single character. */ DO; J = 0; DO K = 1 TO LENGTH(Text); IF SUBSTR(Text, K, 1) ^= S THEN DO; J = J + 1; SUBSTR(Out, J, 1) = SUBSTR (Text, K, 1); END; END; RETURN (SUBSTR(Out, 1, J)); END; /* S has one or more characters. */ J = 0; DO K = 1 TO LENGTH(Text); IF INDEX(S, SUBSTR(Text, K, 1)) = 0 THEN DO; J = J + 1; SUBSTR(Out, J, 1) = SUBSTR (Text, K, 1); END; END; RETURN (SUBSTR(Out, 1, J)); END PACKS; /* This procedure removes characters from a string, compressing those */ /* characters into a contiguous area. The characters to be removed and */ /* included are specified in a mask vector of bits. */ /* If bit in the mask is '1'b, then the corresponding character in the */ /* string is included, otherwise it is omitted. */ /* If the string is "The quick brown fox", and the mask is */ /* 1011000010000000000 the packed string that is returned consists of "Te k". */ PACK2: PROCEDURE (Text, Mask) OPTIONS (REORDER) RETURNS (CHARACTER(32767) VARYING); DECLARE (Text CHARACTER (*), Mask (*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Out CHARACTER (LENGTH(Text)); DECLARE (J, K) FIXED BINARY(31); J = 0; DO K = 1 TO LENGTH(Text); IF Mask(K) THEN DO; J = J + 1; SUBSTR(Out, J, 1) = SUBSTR (Text, K, 1); END; END; RETURN (SUBSTR(Out, 1, J)); END PACK2; /* This procedure removes elements from an array, compressing */ /* those remaining elements into a contiguous arrray. The elements to be removed and */ /* included are specified in a mask vector of bits. */ /* If bit in the mask is '1'b, then the corresponding element in the */ /* array is included, otherwise it is omitted. */ /* If the array is 2, 3, 4, 5, 6, 7, 8, 9, 10, and the mask is */ /* 1, 0, 1, 1, 0, 0, 0, 0, 1, the packed array that is returned consists of */ /* the elements 2, 4, 5, 10. */ PACK3: PROCEDURE (Vector_In, Mask, Vector_Out) OPTIONS (REORDER); DECLARE (Vector_In (*) FLOAT, Mask (*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Vector_Out (*) FLOAT CONTROLLED; DECLARE (J, K) FIXED BINARY(31); ALLOCATE Vector_Out(SUM(Mask)); J = LBOUND(Vector_Out)-1; DO K = LBOUND(Vector_In) TO HBOUND(Vector_In); IF Mask(K) THEN DO; J = J + 1; Vector_Out(J) = Vector_In(K); END; END; END PACK3; /* This procedure removes elements from a matrix, compressing */ /* those remaining elements into a contiguous vector. The elements to be removed and */ /* included are specified in a mask matrix of bits. */ /* If bit in the mask is '1'b, then the corresponding element in the */ /* matrix is included, otherwise it is omitted. */ /* If the matrix is: */ /* 2, 3, 4, */ /* 5, 6, 7, */ /* 8, 9, 10 */ /* and the mask is */ /* 1, 0, 1, */ /* 1, 0, 0, */ /* 0, 0, 1 */ /* the packed vector that is returned consists of */ /* the elements 2, 4, 5, 10. */ PACK4: PROCEDURE (Matrix_In, Mask, Vector_Out) OPTIONS (REORDER); DECLARE (Matrix_In (*,*) FLOAT, Mask (*,*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Vector_Out (*) FLOAT CONTROLLED; DECLARE (J, K, L) FIXED BINARY(31); ALLOCATE Vector_Out(SUM(Mask)); J = LBOUND(Vector_Out)-1; DO K = LBOUND(Matrix_In,1) TO HBOUND(Matrix_In,1); DO L = LBOUND(Matrix_In,2) TO HBOUND(Matrix_In,2); IF Mask(K,L) THEN DO; J = J + 1; Vector_Out(J) = Matrix_In(K,L); END; END; END; END PACK4; %SKIP(4); DECLARE UNPACK GENERIC ( UNPACKV WHEN ((*), (*) BIT, (*), (*)), UNPACKS WHEN ((*), (*) BIT, * , (*)), UNPACKMM WHEN ((*), (*,*) BIT, (*,*), (*,*)), UNPACKMS WHEN ((*), (*,*) BIT, * , (*,*)) ); /* UNPACKS is a subroutine that performs the opposite of PACK. */ /* In the following procedure, Vector_In is the vector to be unpacked, */ /* Mask is an array of bits corresponding to the positions of elements */ /* in the unpacked array, and Fill is a scalar element that is assigned */ /* to unfilled positions in the unpacked array. */ /* When the procedure is executed, consecutive elements in Vector_In */ /* are copied into the unpacked array at locations determined by bits */ /* in Mask. */ UNPACKS: PROCEDURE (Vector_In, Mask, Fill, Vector_Out) OPTIONS (REORDER); DECLARE (Vector_In (*) FLOAT, Mask (*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Fill FLOAT NONASSIGNABLE, Vector_Out (*) FLOAT CONTROLLED; DECLARE (J, K) FIXED BINARY(31); ALLOCATE Vector_Out(LBOUND(Mask):HBOUND(Mask)); J = LBOUND(Vector_In)-1; DO K = LBOUND(Mask) TO HBOUND(Mask); IF Mask(K) THEN DO; J = J + 1; Vector_Out(K) = Vector_In(J); END; ELSE Vector_Out(K) = Fill; END; END UNPACKS; /* UNPACKV is a subroutine that performs the opposite of PACK. */ /* In the following procedure, Vector_In is the vector to be unpacked, */ /* Mask is an array of bits corresponding to the positions of elements */ /* in the unpacked array, and Fill is a vector of the same size */ /* as Vector_Out that whose elements are assigned to unfilled positions */ /* in the unpacked vector. */ /* When the procedure is executed, consecutive elements in Vector_In */ /* are copied into the unpacked vector at locations determined by bits */ /* in Mask. */ UNPACKV: PROCEDURE (Vector_In, Mask, Fill, Vector_Out) OPTIONS (REORDER); DECLARE (Vector_In (*) FLOAT, Mask (*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Fill (*) FLOAT NONASSIGNABLE, Vector_Out (*) FLOAT CONTROLLED; DECLARE (J, K) FIXED BINARY(31); ALLOCATE Vector_Out(LBOUND(Mask):HBOUND(Mask)); J = LBOUND(Vector_In)-1; DO K = LBOUND(Mask) TO HBOUND(Mask); IF Mask(K) THEN DO; J = J + 1; Vector_Out(K) = Vector_In(J); END; ELSE Vector_Out(K) = Fill(K); END; END UNPACKV; /* UNPACKM is a subroutine that performs the opposite of PACK. */ /* In the following procedure, Vector_In is the vector to be unpacked, */ /* Mask is a matrix of bits corresponding to the positions of elements */ /* in the unpacked array, and Fill is a matrix of the same size */ /* as Matrix_Out that whose elements are assigned to unfilled positions */ /* in the unpacked array. */ /* When the procedure is executed, consecutive elements in Vector_In */ /* are copied into the unpacked matrix at locations determined by bits */ /* in Mask. */ UNPACKMS: PROCEDURE (Vector_In, Mask, Fill, Matrix_Out) OPTIONS (REORDER); DECLARE (Vector_In (*) FLOAT, Mask (*,*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Fill FLOAT NONASSIGNABLE, Matrix_Out (*,*) FLOAT CONTROLLED; DECLARE (J, K, L) FIXED BINARY(31); ALLOCATE Matrix_Out(LBOUND(Mask,1):HBOUND(Mask,1), LBOUND(Mask,2):HBOUND(Mask,2)); J = LBOUND(Vector_In)-1; DO K = LBOUND(Mask,1) TO HBOUND(Mask,1); DO L = LBOUND(Mask,2) TO HBOUND(Mask,2); IF Mask(K,L) THEN DO; J = J + 1; Matrix_Out(K,L) = Vector_In(J); END; ELSE Matrix_Out(K,L) = Fill; END; END; END UNPACKMS; /* UNPACKM is a subroutine that performs the opposite of PACK. */ /* In the following procedure, Vector_In is the vector to be unpacked, */ /* Mask is a matrix of bits corresponding to the positions of elements */ /* in the unpacked array, and Fill is a matrix of the same size */ /* as Matrix_Out that whose elements are assigned to unfilled positions */ /* in the unpacked array. */ /* When the procedure is executed, consecutive elements in Vector_In */ /* are copied into the unpacked matrix at locations determined by bits */ /* in Mask. */ UNPACKMM: PROCEDURE (Vector_In, Mask, Fill, Matrix_Out) OPTIONS (REORDER); DECLARE (Vector_In (*) FLOAT, Mask (*,*) BIT (1) ALIGNED) NONASSIGNABLE; DECLARE Fill (*,*) FLOAT NONASSIGNABLE, Matrix_Out (*,*) FLOAT CONTROLLED; DECLARE (J, K, L) FIXED BINARY(31); ALLOCATE Matrix_Out(LBOUND(Mask,1):HBOUND(Mask,1), LBOUND(Mask,2):HBOUND(Mask,2)); J = LBOUND(Vector_In)-1; DO K = LBOUND(Mask,1) TO HBOUND(Mask,1); DO L = LBOUND(Mask,2) TO HBOUND(Mask,2); IF Mask(K,L) THEN DO; J = J + 1; Matrix_Out(K,L) = Vector_In(J); END; ELSE Matrix_Out(K,L) = Fill(K,L); END; END; END UNPACKMM;