Works with: GCC version 7.3.0 - Ubuntu 18.04 64-bit
                                        # Author: Ettore Forigo - Hexwell

.intel_syntax noprefix

.text
.globl main
main:
.PROLOGUE:
    push    rbp
    mov rbp, rsp
    sub rsp, 32
    mov QWORD PTR [rbp-32], rsi         # argv

.BODY:
    mov BYTE PTR [rbp-1], 0             # shift = 0

    .I_LOOP_INIT:
        mov BYTE PTR [rbp-2], 0         # i = 0
        jmp .I_LOOP_CONDITION           # I_LOOP_CONDITION
    .I_LOOP_BODY:
        movzx edx, BYTE PTR[rbp-1]      # shift
        mov eax, edx                    # shift
        sal eax, 2                      # shift << 2 == i * 4
        add eax, edx                    # shift * 4 + shift = shift * 5
        add eax, eax                    # shift * 5 + shift * 5 = shift * 10
        mov ecx, eax                    # shift * 10
        mov rax, QWORD PTR [rbp-32]     # argv
        add rax, 8                      # argv + 1
        mov rdx, QWORD PTR [rax]        # argv[1]
        movzx eax, BYTE PTR [rbp-2]     # i
        add rax, rdx                    # argv[1] + i
        movzx eax, BYTE PTR [rax]       # argv[1][i]
        add eax, ecx                    # shift * 10 + argv[1][i]
        sub eax, 48                     # shift * 10 + argv[1][i] - '0'
        mov BYTE PTR [rbp-1], al        # shift = shift * 10 + argv[1][i] - '0'
    .I_LOOP_INCREMENT:
        movzx eax, BYTE PTR [rbp-2]     # i
        add eax, 1                      # i + 1
        mov BYTE PTR [rbp-2], al        # i++
    .I_LOOP_CONDITION:
        mov rax, QWORD PTR [rbp-32]     # argv
        add rax, 8                      # argv + 1
        mov rax, QWORD PTR [rax]        # argv[1]
        movzx edx, BYTE PTR [rbp-2]     # i
        add rax, rdx                    # argv[1] + i
        movzx rax, BYTE PTR [rax]       # argv[1][i]
        test al, al                     # argv[1][i]?
        jne .I_LOOP_BODY                # I_LOOP_BODY

    .CAESAR_LOOP_INIT:
        mov BYTE PTR [rbp-2], 0         # i = 0
        jmp .CAESAR_LOOP_CONDITION      # CAESAR_LOOP_CONDITION
    .CAESAR_LOOP_BODY:
        mov rax, QWORD PTR [rbp-32]     # argv
        add rax, 16                     # argv + 2
        mov rdx, QWORD PTR [rax]        # argv[2]
        movzx eax, BYTE PTR [rbp-2]     # i
        add rax, rdx                    # argv[2] + i
        mov rbx, rax                    # argv[2] + i
        movzx eax, BYTE PTR [rax]       # argv[2][i]
        cmp al, 32                      # argv[2][i] == ' '
        je .CAESAR_LOOP_INCREMENT       # CAESAR_LOOP_INCREMENT
        movzx edx, BYTE PTR [rbx]       # argv[2][i]
        mov ecx, edx                    # argv[2][i]
        movzx edx, BYTE PTR [rbp-1]     # shift
        add edx, ecx                    # argv[2][i] + shift
        sub edx, 97                     # argv[2][i] + shift - 'a'
        mov BYTE PTR [rbx], dl          # argv[2][i] = argv[2][i] + shift - 'a'
        movzx eax, BYTE PTR [rbx]       # argv[2][i]
        cmp al, 25                      # argv[2][i] <=> 25
        jle .CAESAR_RESTORE_ASCII       # <= CAESAR_RESTORE_ASCII
        movzx edx, BYTE PTR [rbx]       # argv[2][i]
        sub edx, 26                     # argv[2][i] - 26
        mov BYTE PTR [rbx], dl          # argv[2][i] = argv[2][i] - 26
    .CAESAR_RESTORE_ASCII:
        movzx edx, BYTE PTR [rbx]       # argv[2][i]
        add edx, 97                     # argv[2][i] + 'a'
        mov BYTE PTR [rbx], dl          # argv[2][i] = argv[2][i] + 'a'
    .CAESAR_LOOP_INCREMENT:
        movzx eax, BYTE PTR [rbp-2]     # i
        add eax, 1                      # i + 1
        mov BYTE PTR [rbp-2], al        # i++
    .CAESAR_LOOP_CONDITION:
        mov rax, QWORD PTR [rbp-32]     # argv
        add rax, 16                     # argv + 2
        mov rdx, QWORD PTR [rax]        # argv[2]
        movzx eax, BYTE PTR [rbp-2]     # i
        add rax, rdx                    # argv[2] + i
        movzx eax, BYTE PTR [rax]       # argv[2][i]
        test al, al                     # argv[2][i]?
        jne .CAESAR_LOOP_BODY           # CAESAR_LOOP_BODY

    mov rax, QWORD PTR [rbp-32]         # argv
    add rax, 16                         # argv + 2
    mov rax, QWORD PTR [rax]            # argv[2]
    mov rdi, rax                        # argv[2]
    call    puts                        # puts(argv[2])

.RETURN:
    mov eax, 0                          # 0
    leave
    ret                                 # return 0

$ gcc caesar.S -o caesar
$ ./caesar 10 abc
klm
$ ./caesar 16 klm
abc

implement both encoding and decoding functionalities of a Caesar cipher. The cipher uses a key ranging from 1 to 25 to rotate the alphabet letters either left or right. It replaces each letter with the 1st to 25th next letter in the alphabet, wrapping Z back to A. The codes also highlight the cipher's lack of security due to its vulnerability to frequency analysis or brute force attacks. The Caesar cipher is identical to the Vigenère cipher with a key of length 1 and the Rot-13 cipher with a key of 13.


; x86_64 Linux NASM

global _start

%define af_inet 2
%define sock_stream 1
%define default_proto 0
%define sol_sock 1
%define reuse_addr 2
%define reuse_port 15
%define server_port 9001
%define addr_any 0
%define family_offset 0
%define port_offset 2
%define addr_offset 4
%define unused_offset 8
%define addr_len 16
%define buffer_len 64
%define max_connections 3

section .text

; rdi - 16 bit value to be byte swapped
; return - byte swapped value
htn_swap16:

  xor rax, rax
  mov rdx, 0x000000ff

  mov rsi, rdi
  and rsi, rdx
  shl rsi, 8
  or rax, rsi
  shl rdx, 8

  mov rsi, rdi
  and rsi, rdx
  shr rsi, 8
  or rax, rsi
  ret

; return - server socket
create_server_socket:

  mov rax, 41
  mov rdi, af_inet
  mov rsi, sock_stream
  mov rdx, default_proto
  syscall
  push rax

  mov rax, 54
  mov rdi, qword [rsp]
  mov rsi, sol_sock
  mov rdx, reuse_addr
  mov qword [rsp - 16], 1
  lea r10, [rsp - 16]
  mov r8, 4
  syscall

  mov rax, 54
  mov rdi, qword [rsp]
  mov rsi, sol_sock
  mov rdx, reuse_port
  mov qword [rsp - 16], 1
  lea r10, [rsp - 16]
  mov r8, 4
  syscall

  pop rax
  ret

; rdi - socket
; rsi - port
; rdx - connections
; return - void
bind_and_listen:

  push rdi
  push rdx

  mov rdi, rsi
  call htn_swap16

  lea rsi, [rsp - 16]
  mov word [rsi + family_offset], af_inet
  mov word [rsi + port_offset], ax
  mov dword [rsi + addr_offset], addr_any
  mov qword [rsi + unused_offset], 0

  mov rax, 49
  mov rdi, qword [rsp + 8]
  mov rdx, addr_len
  syscall

  mov rax, 50
  pop rsi
  pop rdi
  syscall
  ret

; rdi - server socket
; return - client socket
accept:

  mov rax, 43
  lea rsi, [rsp - 16]
  lea rdx, [rsp - 24]
  syscall
  ret

; rdi - client socket
; return - void
echo:

  push rdi
  mov rax, 0
  lea rsi, [rsp - 104]
  mov rdx, buffer_len
  syscall

  pop rdi
  mov rdx, rax
  lea rsi, [rsp - 112]
  mov rax, 1
  syscall
  ret

_start:

  call create_server_socket
  mov r14, rax

  mov rdi, rax
  mov rsi, server_port
  mov rdx, max_connections
  call bind_and_listen

accept_connection:

  mov rdi, r14
  call accept

  mov r15, rax
  mov rax, 57
  syscall

  test rax, rax
  jz handle_connection

  ; close client socket
  mov rax, 3
  mov rdi, r15
  syscall
  jmp accept_connection

handle_connection:

  mov rdi, r15
  call echo

  close_client:
    mov rax, 3
    mov rdi, r15
    syscall

  close_server:
    mov rax, 3
    mov rdi, r14
    syscall

  exit:
    mov rax, 60
    xor rdi, rdi
    syscall

Implement an echo server that listens on TCP port 12321, accepts and handles multiple simultaneous connections from localhost, echoes complete lines back to clients, and logs connection information. The server remains responsive even if a client sends a partial line or stops reading responses.


Works with: NASM version Linux

%define sys_signal 	48
%define SIGINT			2
%define sys_time	13

extern usleep
extern printf

section .text
	global _start

	_sig_handler:
		mov ebx, end_time
		mov eax, sys_time
		int 0x80
		mov eax, dword [start_time]
		mov ebx, dword [end_time]
		sub ebx, eax
		mov ax, 100
		div ebx
		push ebx
		push p_time
		call printf
		push 0x1
		mov eax, 1
		push eax
		int 0x80
		ret

	_start:
		mov ebx, start_time
		mov eax, sys_time
		int 0x80
		mov ecx, _sig_handler
		mov ebx, SIGINT
		mov eax, sys_signal
		int 0x80
		xor edi, edi
		.looper:
			push 500000
			call usleep
			push edi
			push p_cnt
			call printf
			inc edi
		jmp .looper

section .data
p_time	db "The program has run for %d seconds.",13,10,0
p_cnt		db "%d",13,10,0

section .bss
start_time	resd 1
end_time		resd 1

The code outputs an integer every half second. It handles SIGINT and SIGQUIT signals, typically generated by the user. On receiving these signals, the program stops outputting integers, displays the total runtime in seconds, and then terminates. The functionality is achieved through system calls and signal handlers, avoiding the use of C libraries.


; x86_64 linux nasm

section .bss
number resb 4

section .data
fizz: db "Fizz"
buzz: db "Buzz"
newLine: db 10

section .text
global _start

_start:

  mov rax, 1      ; initialize counter

  loop:
    push rax
    call fizzBuzz
    pop rax
    inc rax
    cmp rax, 100
    jle loop

  mov rax, 60
  mov rdi, 0
  syscall

fizzBuzz:
  mov r10, rax
  mov r15, 0       ; boolean fizz or buzz
  checkFizz:
    xor rdx, rdx   ; clear rdx for division
    mov rbx, 3
    div rbx
    cmp rdx, 0     ; modulo result here
    jne checkBuzz
    mov r15, 1
    mov rsi, fizz
    mov rdx, 4
    mov rax, 1
    mov rdi, 1
    syscall
  checkBuzz:
    mov rax, r10
    xor rdx, rdx
    mov rbx, 5
    div rbx
    cmp rdx, 0
    jne finishLine
    mov r15, 1
    mov rsi, buzz
    mov rdx, 4
    mov rax, 1
    mov rdi, 1
    syscall
  finishLine:      ; print number if no fizz or buzz
    cmp r15, 1
    je nextLine
    mov rax, r10
    call printNum
    ret
    nextLine:
      mov rsi, newLine
      mov rdx, 1
      mov rax, 1
      mov rdi, 1
      syscall
      ret

printNum:          ; write proper digits into number buffer
  cmp rax, 100
  jl lessThanHundred
  mov byte [number], 49
  mov byte [number + 1], 48
  mov byte [number + 2], 48
  mov rdx, 3
  jmp print

  lessThanHundred: ; get digits to write through division
    xor rdx, rdx
    mov rbx, 10
    div rbx
    add rdx, 48
    cmp rax, 0
    je lessThanTen
    add rax, 48
    mov byte [number], al
    mov byte [number + 1], dl
    mov rdx, 2
    jmp print

  lessThanTen:
    mov byte [number], dl
    mov rdx, 1
  print:
    mov byte [number + rdx], 10   ; add newline
    inc rdx
    mov rax, 1
    mov rdi, 1
    mov rsi, number
    syscall
  ret

print numbers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'.


    align 16
; Input year as signed dword in EAX
IsLeapYear:
    test eax,11b
    jz .4
    retn ; 75% : ZF=0, not a leap year
.4:
    mov ecx,100
    cdq
    idiv ecx
    test edx,edx
    jz .100
    cmp edx,edx
    retn ; 24% : ZF=1, leap year
.100:
    test eax,11b
    retn ; 1% : ZF=?, leap year if EAX%400=0

determine if a given year is a leap year in the Gregorian calendar using FASM syntax. The code incorporates a leaf function into the program.


Works with: nasm

section .data
    string db "Hello World", 0

section .bss
    string2 resb 12

section .text
global _main
_main:
    mov ecx, 0
    looping:
        mov al, [string + ecx]
        mov [string2 + ecx], al
        inc ecx
        cmp al, 0 ;copy until we find the terminating 0
        je end
        jmp looping
    end:
        xor eax, eax
        ret

section .data
    string db 11,"Hello World"

section .bss
    string2 resb 12

section .text
global _main
_main:
    xor ecx, ecx ;clear ecx
    mov cl, [string]
    mov [string2], cl ;copy byte signaling length
    mov edx, 1
    looping: ;copy each single byte
        mov al, [string + edx]
        mov [string2 + edx], al
        inc edx
        dec ecx
        cmp ecx, 0
        jg looping
    xor eax, eax
    ret

"Implements functionality to copy a string, differentiating between copying the string content and creating an additional reference to the existing string. It also includes creating a second string with the same content, terminated by 0, and another where the first byte indicates the string length."


;x86-64 assembly code for Microsoft Windows
;Tested in windows 7 Enterprise Service Pack 1 64 bit
;With the AMD FX(tm)-6300 processor
;Assembled with NASM version 2.11.06
;Linked to C library with gcc version 4.9.2 (x86_64-win32-seh-rev1, Built by MinGW-W64 project)

;Assembled and linked with the following commands:
;nasm -f win64 <filename>.asm -o <filename>.obj
;gcc <filename>.obj -o <filename>

;Takes magnitude of Sierpinski Carpet as command line argument.

extern atoi,puts,putchar,exit

section .data
errmsg_noarg: db "Magnitude of Sierpinski Carpet was not specified.",0
errmsg_argnumber: db "There should be no more than one argument.",0

section .bss

section .text
global main

main:

;check for argument
cmp rcx,1
jle err_noarg

;ensure that only one argument was entered
cmp rcx,2
jg err_argnumber

;column in rsi
;row in rdi
;x in r8
;y in r9
;width in r13
;magic number in r14

mov r14,2863311531

;get magnitude in rbx from first arg
mov rcx,[rdx + 8]
call atoi
mov rbx,rax

cmp rbx,0
jz magnitude_zero

;determine dimensions of square
mov rax,1

find_width:

lea rax,[rax * 3]

dec rbx
jg find_width

sub rax,1

mov r13,rax
mov rdi,rax

next_row:

mov rsi,r13

fill_row:

;x in r8, y in r9
mov r8,rsi
mov r9,rdi

is_filled:

;if(x%3==1 && y%3==1)
;x%3 in rbx
mov rax,r8
mov rbx,r8
mul r14
shr rax,33
mov r8,rax
lea rax,[rax * 3]
sub rbx,rax

;y%3 in rcx
mov rax,r9
mov rcx,r9
mul r14
shr rax,33
mov r9,rax
lea rax,[rax * 3]
sub rcx,rax

;x%3==1 && y%3==1
xor rbx,1
xor rcx,1
or rbx,rcx
mov rcx,' '
cmp rbx,0
jz dont_fill

;x>0 || y>0
mov rax,r8
or rax,r9
cmp rax,0
jg is_filled

mov rcx,'#'
dont_fill:

call putchar

dec rsi
jge fill_row

;put newline at the end of each row
mov rcx,0xa
call putchar

dec rdi
jge next_row

xor rcx,rcx
call exit

magnitude_zero:

mov rcx,'#'
call putchar

mov rcx,0xa
call putchar

xor rcx,rcx
call exit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;error message

err_noarg:

mov rcx,errmsg_noarg
call puts

mov rcx,1
call exit

err_argnumber:

mov rcx,errmsg_argnumber
call puts

mov rcx,1
call exit

Sample:
F:\>asciisierpinski.exe
Magnitude of Sierpinski Carpet was not specified.

F:\>asciisierpinski.exe 1 1 1
There should be no more than one arguement.

F:\>asciisierpinski.exe 0
#

F:\>asciisierpinski.exe 1
###
# #
###

F:\>asciisierpinski.exe 2
#########
# ## ## #
#########
###   ###
# #   # #
###   ###
#########
# ## ## #
#########

F:\>asciisierpinski.exe 3
###########################
# ## ## ## ## ## ## ## ## #
###########################
###   ######   ######   ###
# #   # ## #   # ## #   # #
###   ######   ######   ###
###########################
# ## ## ## ## ## ## ## ## #
###########################
#########         #########
# ## ## #         # ## ## #
#########         #########
###   ###         ###   ###
# #   # #         # #   # #
###   ###         ###   ###
#########         #########
# ## ## #         # ## ## #
#########         #########
###########################
# ## ## ## ## ## ## ## ## #
###########################
###   ######   ######   ###
# #   # ## #   # ## #   # #
###   ######   ######   ###
###########################
# ## ## ## ## ## ## ## ## #
###########################

generate a graphical or ASCII-art representation of a Sierpinski carpet of a given order N, where the placement of whitespace and non-whitespace characters is crucial. The ASCII art does not necessarily have to use the '#' character. The program uses magic number division to avoid repeated use of the div instruction in a loop. It also relates to the task of creating a Sierpinski triangle.


Works with: nasm
Works with: windows
section .text

global _main
_main:
    mov eax, 3 ;m
    mov ebx, 4 ;n
    call ack ;returns number in ebx
    ret

ack:
    cmp eax, 0
    je M0 ;if M == 0
    cmp ebx, 0
    je N0 ;if N == 0
    dec ebx ;else N-1
    push eax ;save M
    call ack1 ;ack(m,n) -> returned in ebx so no further instructions needed
    pop eax ;restore M
    dec eax ;M - 1
    call ack1 ;return ack(m-1,ack(m,n-1))
    ret
    M0:
        inc ebx ;return n + 1
        ret
    N0:
        dec eax
        inc ebx ;ebx always 0: inc -> ebx = 1
        call ack1 ;return ack(M-1,1)
        ret

Implement the Ackermann function which is a recursive function that takes two non-negative arguments and returns a value based on the specified conditions. The function should ideally support arbitrary precision due to its rapid growth.


Works with: nasm version Linux
;using sockets on linux with the 0x80 inturrprets.
;
;assemble
;  nasm -o socket.o -f elf32 -g socket.asm
;link
;  ld -o socket socket.o
;
;
;Just some assigns for better readability

%assign SOCK_STREAM         1
%assign AF_INET             2
%assign SYS_socketcall      102
%assign SYS_SOCKET          1
%assign SYS_CONNECT         3
%assign SYS_SEND            9
%assign SYS_RECV            10

section .text
  global _start

;--------------------------------------------------
;Functions to make things easier. :]
;--------------------------------------------------
_socket:
  mov [cArray+0], dword AF_INET
  mov [cArray+4], dword SOCK_STREAM
  mov [cArray+8], dword 0
  mov eax, SYS_socketcall
  mov ebx, SYS_SOCKET
  mov ecx, cArray
  int 0x80
  ret

_connect:
  call _socket
  mov dword [sock], eax
  mov dx, si
  mov byte [edi+3], dl
  mov byte [edi+2], dh
  mov [cArray+0], eax     ;sock;
  mov [cArray+4], edi     ;&sockaddr_in;
  mov edx, 16
  mov [cArray+8], edx   ;sizeof(sockaddr_in);
  mov eax, SYS_socketcall
  mov ebx, SYS_CONNECT
  mov ecx, cArray
  int 0x80
  ret

_send:
  mov edx, [sock]
  mov [sArray+0],edx
  mov [sArray+4],eax
  mov [sArray+8],ecx
  mov [sArray+12], dword 0
  mov eax, SYS_socketcall
  mov ebx, SYS_SEND
  mov ecx, sArray
  int 0x80
  ret

_exit:
  push 0x1
  mov eax, 1
  push eax
  int 0x80

_print:
  mov ebx, 1
  mov eax, 4
  int 0x80
  ret
;--------------------------------------------------
;Main code body
;--------------------------------------------------

_start:
  mov esi, szIp
  mov edi, sockaddr_in
  xor eax,eax
  xor ecx,ecx
  xor edx,edx
  .cc:
    xor   ebx,ebx
  .c:
    lodsb
    inc   edx
    sub   al,'0'
    jb   .next
    imul ebx,byte 10
    add   ebx,eax
    jmp   short .c
  .next:
    mov   [edi+ecx+4],bl
    inc   ecx
    cmp   ecx,byte 4
    jne   .cc

  mov word [edi], AF_INET
  mov esi, szPort
  xor eax,eax
  xor ebx,ebx
  .nextstr1:
    lodsb
    test al,al
    jz .ret1
    sub   al,'0'
    imul ebx,10
    add   ebx,eax
    jmp   .nextstr1
  .ret1:
    xchg ebx,eax
    mov [sport], eax

  mov si, [sport]
  call _connect
  cmp eax, 0
  jnz short _fail
  mov eax, msg
  mov ecx, msglen
  call _send
  call _exit

_fail:
  mov edx, cerrlen
  mov ecx, cerrmsg
  call _print
  call _exit

_recverr:
  call _exit
_dced:
  call _exit

section .data
cerrmsg      db 'failed to connect :(',0xa
cerrlen      equ $-cerrmsg
msg          db 'Hello socket world!',0xa
msglen       equ $-msg

szIp         db '127.0.0.1',0
szPort       db '256',0

section .bss
sock         resd 1
;general 'array' for syscall_socketcall argument arg.
cArray       resd 1
             resd 1
	     resd 1
             resd 1

;send 'array'.
sArray      resd 1
            resd 1
            resd 1
            resd 1
;duh?
sockaddr_in resb 16
;..
sport       resb 2
buff        resb 1024

Works with: MASM

.586
.model flat,stdcall
option casemap:none

include /masm32/include/windows.inc
include /masm32/include/user32.inc
include /masm32/include/kernel32.inc
include /masm32/include/ws2_32.inc

includelib /masm32/lib/user32.lib
includelib /masm32/lib/kernel32.lib
includelib /masm32/lib/ws2_32.lib

WinMain proto :DWORD,:DWORD,:DWORD,:DWORD

.data
   	ClassName 	db "MainWinClass",0
   	AppName  	db "Async Sockets",0
   	szSockStr	db "Hello socket world!",13,10,0
   	szIp		db "127.0.0.1",0
   	port		dd 256

   	wsa			WSADATA <>
   	sa			sockaddr_in <>

.data?
   	hInstance 	dd ?
   	CommandLine dd ?
   	sock		dd ?

.const
WM_SOCK			equ WM_USER+100

.code
start:
	invoke WSAStartup, 200h, addr wsa
	.if eax!=NULL
		invoke ExitProcess, eax
	.else
		invoke GetModuleHandle, NULL
		mov    hInstance,eax
		invoke GetCommandLine
		mov    CommandLine,eax
		invoke WinMain, hInstance,NULL,CommandLine, SW_SHOWDEFAULT
		invoke ExitProcess,eax
	.endif

WinMain proc hInst:HINSTANCE,hPrevInst:HINSTANCE,CmdLine:LPSTR,CmdShow:DWORD
	LOCAL wc:WNDCLASSEX
	LOCAL msg:MSG
	LOCAL hwnd:HWND

	mov   wc.cbSize,SIZEOF WNDCLASSEX
	mov   wc.style, CS_HREDRAW or CS_VREDRAW
	mov   wc.lpfnWndProc, OFFSET WndProc
	mov   wc.cbClsExtra,NULL
	mov   wc.cbWndExtra,NULL
	push  hInstance
	pop   wc.hInstance
	mov   wc.hbrBackground,COLOR_BTNFACE+1
	mov   wc.lpszMenuName,NULL
	mov   wc.lpszClassName,OFFSET ClassName

	invoke LoadIcon,NULL,IDI_APPLICATION
	mov   wc.hIcon,eax
	mov   wc.hIconSm,eax

	invoke LoadCursor,NULL,IDC_ARROW
	mov   wc.hCursor,eax

	invoke RegisterClassEx, addr wc
	INVOKE CreateWindowEx,NULL,ADDR ClassName,ADDR AppName,\
           WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,\
           CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,NULL,NULL,\
           hInst,NULL
	mov   hwnd,eax

	invoke ShowWindow, hwnd,SW_SHOWNORMAL
	invoke UpdateWindow, hwnd

	.WHILE TRUE
		invoke GetMessage, ADDR msg,NULL,0,0
		.BREAK .IF (!eax)
		invoke TranslateMessage, ADDR msg
		invoke DispatchMessage, ADDR msg
	.ENDW

	mov     eax,msg.wParam
	ret
WinMain endp

WndProc proc hWnd:HWND, uMsg:UINT, wParam:WPARAM, lParam:LPARAM

	.IF uMsg==WM_DESTROY
		invoke PostQuitMessage,NULL
	.ELSEIF uMsg==WM_CREATE
		invoke socket, AF_INET,SOCK_STREAM, 0
		.if eax==INVALID_SOCKET
			;error
		.endif
		mov sock, eax
		invoke WSAAsyncSelect, sock, hWnd, WM_SOCK, FD_CONNECT or FD_CLOSE
		.if eax==INVALID_SOCKET
			;error!
		.endif
		mov sa.sin_family, AF_INET
		invoke inet_addr, addr szIp
		mov sa.sin_addr, eax
		invoke htons, port
		mov sa.sin_port, ax
		invoke connect, sock, addr sa, sizeof sa
		.if eax==SOCKET_ERROR
			invoke WSAGetLastError
			.if eax!=WSAEWOULDBLOCK
				;real error.
			.endif
		.endif
	.elseif uMsg==WM_SOCK
		mov edx, lParam
		.if dx==FD_CONNECT
			shr edx, 16
			.if dx==NULL
				invoke lstrlen, addr szSockStr
				invoke send, sock, addr szSockStr, eax, 0
			.else
				;error
			.endif
		.elseif dx==FD_CLOSE
			shr edx, 16
			.if dx==NULL
				invoke SendMessage, hWnd, WM_DESTROY, 0, 0
			.endif
		.endif
	.ELSE
		invoke DefWindowProc,hWnd,uMsg,wParam,lParam
		ret
	.ENDIF

	xor eax,eax
	ret
WndProc endp

end start

Works with: MASM

.586
.model flat,stdcall
option casemap:none

include /masm32/include/windows.inc
include /masm32/include/user32.inc
include /masm32/include/kernel32.inc
include /masm32/include/ws2_32.inc

includelib /masm32/lib/user32.lib
includelib /masm32/lib/kernel32.lib
includelib /masm32/lib/ws2_32.lib

WinMain proto :DWORD,:DWORD,:DWORD,:DWORD

.data
   	ClassName 	db "MainWinClass",0
   	AppName  	db "Blocking Sockets",0
   	szSockStr	db "Hello socket world!",13,10,0
   	szIp		db "127.0.0.1",0
   	port		dd 256

   	wsa			WSADATA <>
   	sa			sockaddr_in <>

.data?
   	hInstance 	dd ?
   	CommandLine dd ?
   	sock		dd ?

.code
start:
	invoke WSAStartup, 200h, addr wsa
	.if eax!=NULL
		invoke ExitProcess, eax
	.else
		invoke GetModuleHandle, NULL
		mov    hInstance,eax
		invoke GetCommandLine
		mov    CommandLine,eax
		invoke WinMain, hInstance,NULL,CommandLine, SW_SHOWDEFAULT
		invoke ExitProcess,eax
	.endif

WinMain proc hInst:HINSTANCE,hPrevInst:HINSTANCE,CmdLine:LPSTR,CmdShow:DWORD
	LOCAL wc:WNDCLASSEX
	LOCAL msg:MSG
	LOCAL hwnd:HWND

	mov   wc.cbSize,SIZEOF WNDCLASSEX
	mov   wc.style, CS_HREDRAW or CS_VREDRAW
	mov   wc.lpfnWndProc, OFFSET WndProc
	mov   wc.cbClsExtra,NULL
	mov   wc.cbWndExtra,NULL
	push  hInstance
	pop   wc.hInstance
	mov   wc.hbrBackground,COLOR_BTNFACE+1
	mov   wc.lpszMenuName,NULL
	mov   wc.lpszClassName,OFFSET ClassName

	invoke LoadIcon,NULL,IDI_APPLICATION
	mov   wc.hIcon,eax
	mov   wc.hIconSm,eax

	invoke LoadCursor,NULL,IDC_ARROW
	mov   wc.hCursor,eax

	invoke RegisterClassEx, addr wc
	INVOKE CreateWindowEx,NULL,ADDR ClassName,ADDR AppName,\
           WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,\
           CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,NULL,NULL,\
           hInst,NULL
	mov   hwnd,eax

	invoke ShowWindow, hwnd,SW_SHOWNORMAL
	invoke UpdateWindow, hwnd

	.WHILE TRUE
		invoke GetMessage, ADDR msg,NULL,0,0
		.BREAK .IF (!eax)
		invoke TranslateMessage, ADDR msg
		invoke DispatchMessage, ADDR msg
	.ENDW

	mov     eax,msg.wParam
	ret
WinMain endp

WndProc proc hWnd:HWND, uMsg:UINT, wParam:WPARAM, lParam:LPARAM

	.IF uMsg==WM_DESTROY
		invoke PostQuitMessage,NULL
	.ELSEIF uMsg==WM_CREATE
		invoke socket, AF_INET,SOCK_STREAM, 0
		.if eax==INVALID_SOCKET
			;error
		.endif
		mov sock, eax
		mov sa.sin_family, AF_INET
		invoke inet_addr, addr szIp
		mov sa.sin_addr, eax
		invoke htons, port
		mov sa.sin_port, ax
		invoke connect, sock, addr sa, sizeof sa
		invoke lstrlen, addr szSockStr
		invoke send, sock, addr szSockStr, eax, 0
	.ELSE
		invoke DefWindowProc,hWnd,uMsg,wParam,lParam
		ret
	.ENDIF

	xor eax,eax
	ret
WndProc endp

end start

Open a socket to localhost on port 256, send the message "hello socket world", and then close the socket. The code operates in non-blocking mode.


; x86_84 Linux nasm
section .text

isPalindrome:
  mov rsi, rax
  mov rdi, rax

  get_end:
    cmp byte [rsi], 0
    je get_result
    inc rsi
    jmp get_end

  get_result:
    mov rax, 0
    dec rsi

    compare:
      mov cl, byte [rdi]
      cmp byte [rsi], cl
      jne not_palindrome
      cmp rsi, rdi
      je palindrome
      inc rdi
      cmp rdi, rsi
      je palindrome
      dec rsi
      jmp compare

  not_palindrome:
    mov rax, 0
    ret
  palindrome:
    mov rax, 1
    ret

implement a function to check if a given sequence of characters is a palindrome. It also supports Unicode characters. Additionally, it includes a second function to detect inexact palindromes, ignoring white-space, punctuation, and case-sensitivity. It may also be useful for testing a function.


implement a stack data structure with basic operations such as push, pop, and empty. The stack follows a last in, first out (LIFO) access policy. The stack is accessed from its top and can be used for resource management, particularly memory.


sub fib_iter {
  my $n = shift;
  use bigint try => "GMP,Pari";
  my ($v2,$v1) = (-1,1);
  ($v2,$v1) = ($v1,$v2+$v1) for 0..$n;
  $v1;
}
sub fibRec {
    my $n = shift;
    $n < 2 ? $n : fibRec($n - 1) + fibRec($n - 2);
}

# Uses GMP method so very fast
use Math::AnyNum qw/fibonacci/;
say fibonacci(10000);

# Uses GMP method, so also very fast
use Math::GMP;
say Math::GMP::fibonacci(10000);

# Binary ladder, GMP if available, Pure Perl otherwise
use ntheory qw/lucasu/;
say lucasu(1, -1, 10000);

# All Perl
use Math::NumSeq::Fibonacci;
my $seq = Math::NumSeq::Fibonacci->new;
say $seq->ith(10000);

# All Perl
use Math::Big qw/fibonacci/;
say 0+fibonacci(10000);  # Force scalar context

# Perl, gives floating point *approximation*
use Math::Fibonacci qw/term/;
say term(10000);

sub fibonacci {
    my $n = shift;

    return 0 if $n <  1;
    return 1 if $n == 1;

    my @numbers = (0, 1);

    push @numbers, $numbers[-1] + $numbers[-2] foreach 2 .. $n;

    return $numbers[-1];
}

print "Fibonacci($_) -> ", (fibonacci $_), "\n"
    foreach (0 .. 20, 50, 93, 94, 100, 200, 1000, 1476, 1477);

The code generates the nth Fibonacci number using either an iterative or recursive approach. It optionally supports negative n values by inversely applying the Fibonacci sequence formula. The code stores all Fibonacci numbers up to n in an array and returns the nth Fibonacci number. It works best for positive integers and may switch to scientific notation for n>93 or treat numbers as infinite for n>1476. Performance is not typically an issue until 100k. The code can be optimized for large values using GMP.


select certain elements from an array into a new array in a generic way. Specifically, it selects all even numbers from an array. Optionally, it can also filter destructively by modifying the original array instead of creating a new one.


my $str = 'abcdefgh';
print substr($str, 2, 3), "\n"; # Returns 'cde'
print substr($str, 2), "\n"; # Returns 'cdefgh'
print substr($str, 0, -1), "\n"; #Returns 'abcdefg'
print substr($str, index($str, 'd'), 3), "\n"; # Returns 'def'
print substr($str, index($str, 'de'), 3), "\n"; # Returns 'def'

- Extracts a substring starting from the nth character of a specific length m.
- Extracts a substring starting from the nth character up to the end of the string.
- Returns the entire string excluding the last character.
- Extracts a substring starting from a known character within the string of length m.
- Extracts a substring starting from a known substring within the string of length m.
- Supports any valid Unicode code point, including those in the Basic Multilingual Plane or above it.
- References logical characters (code points), not 8-bit code units for UTF-8 or 16-bit code units for UTF-16.
- Does not necessarily support all Unicode characters for other encodings like 8-bit ASCII, or EUC-JP.


use utf8;
binmode STDOUT, ":utf8";

# to reverse characters (code points):
print scalar reverse('visor'), "\n";

# to reverse graphemes:
print join("", reverse "José" =~ /\X/g), "\n";

$string = 'ℵΑΩ 駱駝道 🤔 🇸🇧 🇺🇸 🇬🇧 👨👩👧👦🆗🗺';
print join("", reverse $string =~ /\X/g), "\n";

"Reverses a given string while preserving the order of Unicode combining characters. For instance, it transforms "asdf" into "fdsa" and "as⃝df̅" into "f̅ds⃝a". Note: the reverse() function is applicable to Lists or scalars, not strings."


use Math::Cartesian::Product;

# Pregenerate all forward and reverse translations
sub playfair {
    our($key,$from) = @_;
    $from //= 'J';
    our $to = $from eq 'J' ? 'I' : '';
    my(%ENC,%DEC,%seen,@m);

    sub canon {
        my($str) = @_;
        $str =~ s/[^[:alpha:]]//g;
        $str =~ s/$from/$to/gi;
        uc $str;
    }

    my @uniq = grep { ! $seen{$_}++ } split '', canon($key . join '', 'A'..'Z');
    while (@uniq) { push @m, [splice @uniq, 0, 5] }

    # Map pairs in same row.
    for my $r (@m)  {
        for my $x (cartesian {@_} [0..4], [0..4]) {
        my($i,$j) = @$x;
        next if $i == $j;
        $ENC{ @$r[$i] . @$r[$j] } =  @$r[($i+1)%5] . @$r[($j+1)%5];
        }
    }

    # Map pairs in same column.
    for my $c (0..4) {
        my @c = map { @$_[$c] } @m;
        for my $x (cartesian {@_} [0..4], [0..4]) {
        my($i,$j) = @$x;
        next if $i == $j;
        $ENC{ $c[$i] . $c[$j] } = $c[($i+1)%5] . $c[($j+1)%5];
        }
    }

    # Map pairs with cross-connections.
    for my $x (cartesian {@_} [0..4], [0..4], [0..4], [0..4]) {
        my($i1,$j1,$i2,$j2) = @$x;
        next if $i1 == $i2 or $j1 == $j2;
        $ENC{ $m[$i1][$j1] . $m[$i2][$j2] } = $m[$i1][$j2] . $m[$i2][$j1];
    }

    # Generate reverse translations.
     while (my ($k, $v) = each %ENC) { $DEC{$v} = $k }

    # Return code-refs for encoding/decoding routines
    return
    sub { my($red) = @_; # encode
        my $str = canon($red);

        my @list;
        while ($str =~ /(.)(?(?=\1)|(.?))/g) {
            push @list, substr($str,$-[0], $-[2] ? 2 : 1);
        }
        join ' ', map { length($_)==1 ? $ENC{$_.'X'} : $ENC{$_} } @list;
    },
    sub { my($black) = @_; # decode
        join ' ', map { $DEC{$_} } canon($black) =~ /../g;
    }
}

my($encode,$decode) = playfair('Playfair example');

my $orig  = "Hide the gold in...the TREESTUMP!!!";
my $black = &$encode($orig);
my $red   = &$decode($black);
print " orig:\t$orig\n";
print "black:\t$black\n";
print "  red:\t$red\n";

Implement the Playfair cipher for both encryption and decryption. It allows the user to choose whether 'J' equals 'I' or there's no 'Q' in the alphabet. The resulting encrypted and decrypted messages are presented in capitalized digraphs, separated by spaces.


Implement Dijkstra's algorithm to find the shortest path from a source node to all other nodes in a graph. The graph is represented by an adjacency matrix or list, and a start node. The algorithm outputs a set of edges representing the shortest path to each reachable node. The program also interprets the output to display the shortest path from the source node to specific nodes.


"Function to calculate two possible circles given two points and a radius in 2D space. The function handles special cases such as when radius is zero, points are coincident, points form a diameter, or points are too distant. The function returns the circles or a special indication when two equal or distinct circles cannot be returned."


Implement the main step of the GOST 28147-89 symmetric encryption algorithm, which involves taking a 64-bit block of text and one of the eight 32-bit encryption key elements, using a replacement table, and returning an encrypted block.


while (1) {
    my $a = int(rand(20));
    print "$a\n";
    if ($a == 10) {
        last;
    }
    my $b = int(rand(20));
    print "$b\n";
}

generate and print random numbers from 0 to 19. If the generated number is 10, the loop stops. If the number is not 10, a second random number is generated and printed before the loop restarts. If 10 is never generated, the loop runs indefinitely.


use strict;
use utf8;

sub factors {
	my $n = shift;
	my $p = 2;
	my @out;

	while ($n >= $p * $p) {
		while ($n % $p == 0) {
			push @out, $p;
			$n /= $p;
		}
		$p = next_prime($p);
	}
	push @out, $n if $n > 1 || !@out;
	@out;
}

sub next_prime {
	my $p = shift;
	do { $p = $p == 2 ? 3 : $p + 2 } until is_prime($p);
	$p;
}

my %pcache;
sub is_prime {
	my $x = shift;
	$pcache{$x} //=	(factors($x) == 1)
}

sub mtest {
	my @bits = split "", sprintf("%b", shift);
	my $p = shift;
	my $sq = 1;
	while (@bits) {
		$sq = $sq * $sq;
		$sq *= 2 if shift @bits;
		$sq %= $p;
	}
	$sq == 1;
}

for my $m (2 .. 60, 929) {
	next unless is_prime($m);
	use bigint;

	my ($f, $k, $x) = (0, 0, 2**$m - 1);

	my $q;
	while (++$k) {
		$q = 2 * $k * $m + 1;
		next if (($q & 7) != 1 && ($q & 7) != 7);
		next unless is_prime($q);
		last if $q * $q > $x;
		last if $f = mtest($m, $q);
	}

	print $f? "M$m = $x = $q × @{[$x / $q]}\n"
		: "M$m = $x is prime\n";
}

implement a method to find a factor of a Mersenne number, specifically 2^929-1. The method uses the modPow operation, binary conversion of the exponent, and a Lucas-Lehmer test to efficiently determine if a number is a factor of the Mersenne number. The code also utilizes GMP's modular exponentiation and a simple probable prime test for small numbers. It stops when 2kP+1 > sqrt(N). The method is optimized for Mersenne numbers where P is prime.


Library: XML::XPathXPath
use XML::XPath qw();

my $x = XML::XPath->new('<inventory ... </inventory>');

[$x->findnodes('//item[1]')->get_nodelist]->[0];
print $x->findnodes_as_string('//price');
$x->findnodes('//name')->get_nodelist;

1. Retrieves the first "item" element from the XML document.
2. Prints out each "price" element from the XML document.
3. Gets an array of all the "name" elements from the XML document.


use strict;

package Set; # likely will conflict with stuff on CPAN
use overload
	'""'	=> \&str,
	'bool'	=> \&count,
	'+='	=> \&add,
	'-='	=> \&del,
	'-'	=> \&diff,
	'=='	=> \&eq,
	'&'	=> \&intersection,
	'|'	=> \&union,
	'^'	=> \&xdiff;

sub str {
	my $set = shift;
	# This has drawbacks: stringification is used as set key
	# if the set is added to another set as an element, which
	# may cause inconsistencies if the element set is modified
	# later.  In general, a hash key loses its object identity
	# anyway, so it's not unique to us.
	"Set{ ".  join(", " => sort map("$_", values %$set)) . " }"
}

sub new {
	my $pkg = shift;
	my $h = bless {};
	$h->add($_) for @_;
	$h
}

sub add {
	my ($set, $elem) = @_;
	$set->{$elem} = $elem;
	$set
}

sub del {
	my ($set, $elem) = @_;
	delete $set->{$elem};
	$set
}

sub has { # set has element
	my ($set, $elem) = @_;
	exists $set->{$elem}
}

sub union {
	my ($this, $that) = @_;
	bless { %$this, %$that }
}

sub intersection {
	my ($this, $that) = @_;
	my $s = new Set;
	for (keys %$this) {
		$s->{$_} = $this->{$_} if exists $that->{$_}
	}
	$s
}

sub diff {
	my ($this, $that) = @_;
	my $s = Set->new;
	for (keys %$this) {
		$s += $this->{$_} unless exists $that->{$_}
	}
	$s
}

sub xdiff { # xor, symmetric diff
	my ($this, $that) = @_;
	my $s = new Set;
	bless { %{ ($this - $that) | ($that - $this) } }
}

sub count { scalar(keys %{+shift}) }

sub eq {
	my ($this, $that) = @_;
	!($this - $that) && !($that - $this);
}

sub contains { # this is a superset of that
	my ($this, $that) = @_;
	for (keys %$that) {
		return 0 unless $this->has($_)
	}
	return 1
}

package main;
my ($x, $y, $z, $w);

$x = Set->new(1, 2, 3);
$x += $_ for (5 .. 7);
$y = Set->new(1, 2, 4, $x); # not the brightest idea

print "set x is: $x\nset y is: $y\n";
for (1 .. 4, $x) {
	print "$_ is", $y->has($_) ? "" : " not", " in y\n";
}

print "union: ", $x | $y, "\n";
print "intersect: ", $x & $y, "\n";
print "z = x - y = ", $z = $x - $y, "\n";
print "y is ", $x->contains($y) ? "" : "not ", "a subset of x\n";
print "z is ", $x->contains($z) ? "" : "not ", "a subset of x\n";
print "z = (x | y) - (x & y) = ", $z = ($x | $y) - ($x & $y), "\n";
print "w = x ^ y = ", $w = ($x ^ $y), "\n";
print "w is ", ($w == $z) ? "" : "not ", "equal to z\n";
print "w is ", ($w == $x) ? "" : "not ", "equal to x\n";

demonstrate various set operations including set creation, testing for an element in a set, performing union, intersection, and difference operations between two sets, checking if a set is a subset or equal to another set. Optional operations such as modifying a mutable set and additional set operations may also be included. The set could be implemented using an associative array, a binary search tree, a hash table, or an ordered array of binary bits. The code also includes the time complexity of the basic test operation with different data structures. It also references Set::Object from CPAN for a more robust implementation.


#! /usr/bin/perl -w

use Time::Local;
use strict;

foreach my $i (2008 .. 2121)
{
  my $time = timelocal(0,0,0,25,11,$i);
  my ($s,$m,$h,$md,$mon,$y,$wd,$yd,$is) = localtime($time);
  if ( $wd == 0 )
  {
    print "25 Dec $i is Sunday\n";
  }
}

exit 0;

"Determines the years between 2008 and 2121 when Christmas falls on a Sunday by using standard date handling libraries. It also compares the results with other languages to identify any anomalies in date handling, such as overflow in types used to represent dates/times."


The code performs QR decomposition of a given matrix using the method of Householder reflections. It demonstrates this by decomposing a sample matrix from a Wikipedia article. The code also applies the QR decomposition to solve linear least squares problems from Polynomial regression. It handles cases where the matrix is not square by cutting off zero padded bottom rows. The decomposition process involves reflecting a given vector about a plane, transforming the matrix to remove all subdiagonal elements, and producing an orthogonal matrix. The code also solves the square upper triangular system by back substitution.


Library: List::MoreUtilsMoreUtils

use List::MoreUtils qw(uniq);

my @uniq = uniq qw(1 2 3 a b c 2 3 4 b c d);

my %seen;
my @uniq = grep {!$seen{$_}++} qw(1 2 3 a b c 2 3 4 b c d);

my %hash = map { $_ => 1 } qw(1 2 3 a b c 2 3 4 b c d);
my @uniq = keys %hash;

my %seen;
@seen{qw(1 2 3 a b c 2 3 4 b c d)} = ();
my @uniq = keys %seen;

implement three methods to remove duplicate elements from an array. The first method uses a hash table to eliminate duplicates, the second method sorts the elements and removes consecutive duplicates, and the third method iterates through the list, checking and discarding any repeated elements. The order of first appearance of each element is preserved. Note that the solutions may convert elements to strings in the result, hence losing the ability to be dereferenced.


sub quick_sort {
    return @_ if @_ < 2;
    my $p = splice @_, int rand @_, 1;
    quick_sort(grep $_ < $p, @_), $p, quick_sort(grep $_ >= $p, @_);
}

my @a = (4, 65, 2, -31, 0, 99, 83, 782, 1);
@a = quick_sort @a;
print "@a\n";

implement the Quicksort algorithm to sort an array or list of elements. The algorithm works by choosing a pivot element and dividing the rest of the elements into two partitions - one with elements less than the pivot and the other with elements greater than the pivot. It then recursively sorts these partitions and joins them with the pivot to get the sorted array. The codes also include an optimized version of Quicksort that works in place by swapping elements within the array to avoid memory allocation of more arrays. The pivot selection method is not specified.


display the current date in the formats "2007-11-23" and "Friday, November 23, 2007".


use Algorithm::Combinatorics "subsets";
my @S = ("a","b","c");
my @PS;
my $iter = subsets(\@S);
while (my $p = $iter->next) {
  push @PS, "[@$p]"
}
say join("  ",@PS);

The code defines a function that takes a set as input and generates its power set. It handles edge cases such as an empty set and a set containing only the empty set. The code also demonstrates the ability to handle large sets with minimal memory usage. It uses either a built-in set type or a custom-defined set type with necessary operations. The code also provides solutions using recursion and list folding. It uses an iterator to process each subset immediately, reducing memory usage. It also demonstrates the use of Perl's List::Util core module and the CPAN module Set::Object for set implementation.


The code is a function that takes a positive integer as input and returns its equivalent in Roman numerals. It processes each digit separately, from left to right, skipping zeros. The function is simple, efficient, and doesn't require any experimental modules. It produces the same output as the Math::Roman module and the Raku example.


 my @empty;
 my @empty_too = ();

 my @populated   = ('This', 'That', 'And', 'The', 'Other');
 print $populated[2];  # And

 my $aref = ['This', 'That', 'And', 'The', 'Other'];
 print $aref->[2];  # And

my @arr;

push @arr, 1;
push @arr, 3;

$arr[0] = 2;

print $arr[0];

 my @multi_dimensional = (
     [0, 1, 2, 3],
     [qw(a b c d e f g)],
     [qw(! $ % & *)],
 );

demonstrate the basic syntax of arrays in the specific programming language, including creating an array, assigning values, and retrieving elements. It also showcases the use of both fixed-length and dynamic arrays, as well as the process of pushing a value into the array. The code also includes examples of in-line, dynamic, and two-dimensional arrays.


Works with: Perl version 5.8.8
#!/usr/bin/perl

open my $fh_in, '<', 'input.txt' or die "could not open <input.txt> for reading: $!";
open my $fh_out, '>', 'output.txt' or die "could not open <output.txt> for writing: $!";
# '>' overwrites file, '>>' appends to file, just like in the shell

binmode $fh_out; # marks filehandle for binary content on systems where that matters

print $fh_out $_ while <$fh_in>;
# prints current line to file associated with $fh_out filehandle

# the same, less concise
#while (<$fh_in>) {
#  print $fh_out $_;
#};

close $fh_in;
close $fh_out;

demonstrate how to create a file named "output.txt" and write into it the contents of "input.txt" file using an intermediate variable. The program also showcases reading from a file into a variable and writing a variable's contents into a file. It also highlights the use of Perl's IO disciplines for automatic application of chainable transformations on the input and output.


Works with: Perl version 5.x
my $string = "alphaBETA";
print uc($string), "\n"; # => "ALPHABETA"
print lc($string), "\n"; # => "alphabeta"
$string =~ tr/[a-z][A-Z]/[A-Z][a-z]/; print "$string\n"; # => ALPHAbeta

print ucfirst($string), "\n"; # => "AlphaBETA"
print lcfirst("FOObar"), "\n"; # => "fOObar"

demonstrate the conversion of the string "alphaBETA" to both upper-case and lower-case using the default encoding or ASCII. The code also showcases additional case conversion functions available in the language library, such as swapping case or capitalizing the first letter. The code is compatible with Perl 4 if "my" is removed.


use strict;
use warnings;
use POSIX qw(ceil);

sub dist {
   my ($a, $b) = @_;
   return sqrt(($a->[0] - $b->[0])**2 +
               ($a->[1] - $b->[1])**2)
}

sub closest_pair_simple {
    my @points = @{ shift @_ };
    my ($a, $b, $d) = ( $points[0], $points[1], dist($points[0], $points[1]) );
    while( @points ) {
        my $p = pop @points;
        for my $l (@points) {
            my $t = dist($p, $l);
            ($a, $b, $d) = ($p, $l, $t) if $t < $d;
        }
    }
    $a, $b, $d
}

sub closest_pair {
   my @r = @{ shift @_ };
   closest_pair_real( [sort { $a->[0] <=> $b->[0] } @r], [sort { $a->[1] <=> $b->[1] } @r] )
}

sub closest_pair_real {
    my ($rx, $ry) = @_;
    return closest_pair_simple($rx) if scalar(@$rx) <= 3;

    my(@yR, @yL, @yS);
    my $N = @$rx;
    my $midx = ceil($N/2)-1;
    my @PL = @$rx[      0 .. $midx];
    my @PR = @$rx[$midx+1 .. $N-1];
    my $xm = $$rx[$midx]->[0];
    $_->[0] <= $xm ? push @yR, $_ : push @yL, $_ for @$ry;
    my ($al, $bl, $dL) = closest_pair_real(\@PL, \@yR);
    my ($ar, $br, $dR) = closest_pair_real(\@PR, \@yL);
    my ($w1, $w2, $closest) = $dR > $dL ? ($al, $bl, $dL) : ($ar, $br, $dR);
    abs($xm - $_->[0]) < $closest and push @yS, $_ for @$ry;

    for my $i (0 .. @yS-1) {
        my $k = $i + 1;
        while ( $k <= $#yS and ($yS[$k]->[1] - $yS[$i]->[1]) < $closest ) {
            my $d = dist($yS[$k], $yS[$i]);
            ($w1, $w2, $closest) = ($yS[$k], $yS[$i], $d) if $d < $closest;
            $k++;
        }
    }
    $w1, $w2, $closest
}

my @points;
push @points, [rand(20)-10, rand(20)-10] for 1..5000;
printf "%.8f between (%.5f, %.5f), (%.5f, %.5f)\n", $_->[2], @{$$_[0]}, @{$$_[1]}
    for [closest_pair_simple(\@points)], [closest_pair(\@points)];

The code provides two functions to solve the Closest Pair of Points problem in a two-dimensional space. The first function uses a brute-force algorithm with a time complexity of O(n^2) to find the closest pair of points among a given set. The second function uses a more efficient divide and conquer approach with a time complexity of O(n log n) to solve the same problem. The divide and conquer function is significantly faster than the brute-force function.


use strict;
my @c = (); # create an empty "array" collection

# fill it
push @c, 10, 11, 12;
push @c, 65;
# print it
print join(" ",@c) . "\n";

# create an empty hash
my %h = ();
# add some pair
$h{'one'} = 1;
$h{'two'} = 2;
# print it
foreach my $i ( keys %h ) {
    print $i . " -> " . $h{$i} . "\n";
}

The code creates a collection and adds several values to it, using the concept of collections in statically-typed languages where values are typically of a common data type. The code may involve usage of arrays, associative arrays, compound data types, linked lists, queues, sets, stacks, and Perl's array and hashes.


my (@names, @val, @weight, @vol, $max_vol, $max_weight, $vsc, $wsc);

if (1) { # change 1 to 0 for different data set
        @names  = qw(panacea    icor    gold);
        @val    = qw(3000       1800    2500);
        @weight = qw(3          2       20  );
        @vol    = qw(25         15      2   );
        $max_weight = 250;
        $max_vol = 250;
        $vsc = 1000;
        $wsc = 10;
} else { # with these numbers cache would have been useful
        @names  = qw(panacea    icor    gold    banana  monkey  );
        @val    = qw(17         11      5       3       34      );
        @weight = qw(14         3       2       2       10      );
        @vol    = qw(3          4       2       1       12      );
        $max_weight = 150;
        $max_vol = 100;
        $vsc = $wsc = 1;
}

my @cache;
my ($hits, $misses) = (0, 0);
sub solu {
        my ($i, $w, $v) = @_;
        return [0, []] if $i < 0;

        if ($cache[$i][$w][$v]) {
                $hits ++;
                return $cache[$i][$w][$v]
        }
        $misses ++;

        my $x = solu($i - 1, $w, $v);

        my ($w1, $v1);
        for (my $t = 1; ; $t++) {
                last if ($w1 = $w - $t * $weight[$i]) < 0;
                last if ($v1 = $v - $t * $vol[$i]) < 0;

                my $y = solu($i - 1, $w1, $v1);

                if ( (my $tmp = $y->[0] + $val[$i] * $t) > $x->[0] ) {
                        $x = [ $tmp, [ @{$y->[1]}, [$i, $t] ] ];
                }
        }

        $cache[$i][$w][$v] = $x
}

my $x = solu($#names, $max_weight, $max_vol);
print   "Max value $x->[0], with:\n",
        "    Item\tQty\tWeight   Vol    Value\n", '-'x 50, "\n";

my ($wtot, $vtot) = (0, 0);
for (@{$x->[1]}) {
        my $i = $_->[0];
        printf  "    $names[$i]:\t% 3d  % 8d% 8g% 8d\n",
                $_->[1],
                $weight[$i] * $_->[1] / $wsc,
                $vol[$i] * $_->[1] / $vsc,
                $val[$i] * $_->[1];

        $wtot += $weight[$i] * $_->[1];
        $vtot += $vol[$i] * $_->[1];
}
print   "-" x 50, "\n";
printf  "    Total:\t     % 8d% 8g% 8d\n",
        $wtot/$wsc, $vtot/$vsc, $x->[0];

print "\nCache hit: $hits\tmiss: $misses\n";

"Output: The code calculates the maximum value of items a traveler can carry in his knapsack, given the weight and volume constraints, from a selection of items with varying values, weights, and volumes. It uses a dynamic programming approach to solve the unbounded knapsack problem and only needs to provide one of the four possible solutions."


generates a comma-separated list from 1 to 10 using a loop, with separate output statements for the number and the comma. In the last iteration, only the number is outputted, not the comma. This task is typically solved in Perl using join.


sub print_topo_sort {
    my %deps = @_;

    my %ba;
    while ( my ( $before, $afters_aref ) = each %deps ) {
        for my $after ( @{ $afters_aref } ) {
            $ba{$before}{$after} = 1 if $before ne $after;
            $ba{$after} ||= {};
        }
    }

    while ( my @afters = sort grep { ! %{ $ba{$_} } } keys %ba ) {
        print "@afters\n";
        delete @ba{@afters};
        delete @{$_}{@afters} for values %ba;
    }

    print !!%ba ? "Cycle found! ". join( ' ', sort keys %ba ). "\n" : "---\n";
}

my %deps = (
    des_system_lib => [qw( std synopsys std_cell_lib des_system_lib dw02
                                                        dw01 ramlib ieee )],
    dw01           => [qw( ieee dw01 dware gtech                         )],
    dw02           => [qw( ieee dw02 dware                               )],
    dw03           => [qw( std synopsys dware dw03 dw02 dw01 ieee gtech  )],
    dw04           => [qw( dw04 ieee dw01 dware gtech                    )],
    dw05           => [qw( dw05 ieee dware                               )],
    dw06           => [qw( dw06 ieee dware                               )],
    dw07           => [qw( ieee dware                                    )],
    dware          => [qw( ieee dware                                    )],
    gtech          => [qw( ieee gtech                                    )],
    ramlib         => [qw( std ieee                                      )],
    std_cell_lib   => [qw( ieee std_cell_lib                             )],
    synopsys       => [qw(                                               )],
);
print_topo_sort(%deps);
push @{ $deps{'dw01'} }, 'dw04'; # Add unresolvable dependency
print_topo_sort(%deps);

implement a function to perform a topological sort on VHDL libraries based on their dependencies. The function returns a valid compile order, flags un-orderable dependencies, and ignores self-dependencies. It also allows for parallel building of independent libraries. The function uses either Kahn's 1962 topological sort or depth-first search algorithm.


$str1 =~ /^\Q$str2\E/  # true if $str1 starts with $str2
$str1 =~ /\Q$str2\E/   # true if $str1 contains $str2
$str1 =~ /\Q$str2\E$/  # true if $str1 ends with $str2

index($str1, $str2) == 0                               # true if $str1 starts with $str2
index($str1, $str2) != -1                              # true if $str1 contains $str2
rindex($str1, $str2) == length($str1) - length($str2)  # true if $str1 ends with $str2

substr($str1, 0, length($str2)) eq $str2  # true if $str1 starts with $str2
substr($str1, - length($str2)) eq $str2   # true if $str1 ends with $str2

print $-[0], "\n" while $str1 =~ /\Q$str2\E/g;  # using a regex

my $i = -1; print $i, "\n" while ($i = index $str1, $str2, $i + 1) != -1;  # using index

- Checks if the first string starts with the second string
- Checks if the first string contains the second string anywhere within it
- Checks if the first string ends with the second string
- Optionally, prints the location of the second string within the first string
- Optionally, handles multiple occurrences of the second string within the first string
- Implements these functionalities using regexes, index, and substr methods
- As a bonus task, prints all positions where the second string appears in the first string.


Library: ntheory
use ntheory qw/forperm/;
use Set::CrossProduct;

sub four_sq_permute {
    my($list) = @_;
    my @solutions;
    forperm {
       @c = @$list[@_];
       push @solutions, [@c] if check(@c);
    } @$list;
    print +@solutions . " unique solutions found using: " . join(', ', @$list) . "\n";
    return @solutions;
}

sub four_sq_cartesian {
    my(@list) = @_;
    my @solutions;
    my $iterator = Set::CrossProduct->new( [(@list) x 7] );
    while( my $c = $iterator->get ) {
       push @solutions, [@$c] if check(@$c);
    }
    print +@solutions . " non-unique solutions found using: " . join(', ', @{@list[0]}) . "\n";
    return @solutions;
}

sub check {
    my(@c) = @_;
    $a = $c[0] + $c[1];
    $b = $c[1] + $c[2] + $c[3];
    $c = $c[3] + $c[4] + $c[5];
    $d = $c[5] + $c[6];
    $a == $b and $a == $c and $a == $d;
}

sub display {
    my(@solutions) = @_;
    my $fmt = "%2s " x 7 . "\n";
    printf $fmt, ('a'..'g');
    printf $fmt, @$_ for @solutions;
    print "\n";
}

display four_sq_permute( [1..7] );
display four_sq_permute( [3..9] );
display four_sq_permute( [8, 9, 11, 12, 17, 18, 20, 21] );
four_sq_cartesian( [0..9] );

The code generates all possible solutions for a 4-squares puzzle where the sum of the values in each square is equal. It finds solutions for unique values ranging from 1 to 7, and from 3 to 9. It also calculates the number of solutions for non-unique values ranging from 0 to 9. The solutions are generated using the ntheory and Set::CrossProduct modules.


use utf8;                # interpret source code as UTF8
binmode STDOUT, ':utf8'; # allow printing wide chars without warning
$|++;                    # disable output buffering

my ($rows, $cols) = split /\s+/, `stty size`;
my $x = int($rows / 2 - 1);
my $y = int($cols / 2 - 16);

my @chars = map {[ /(...)/g ]}
            ("┌─┐  ╷╶─┐╶─┐╷ ╷┌─╴┌─╴╶─┐┌─┐┌─┐   ",
             "│ │  │┌─┘╶─┤└─┤└─┐├─┐  │├─┤└─┤ : ",
             "└─┘  ╵└─╴╶─┘  ╵╶─┘└─┘  ╵└─┘╶─┘   ");

while (1) {
    my @indices = map { ord($_) - ord('0') } split //,
                  sprintf("%02d:%02d:%02d", (localtime(time))[2,1,0]);

    clear();
    for (0 .. $#chars) {
      position($x + $_, $y);
      print "@{$chars[$_]}[@indices]";
    }
    position(1, 1);

    sleep 1;
}

sub clear { print "\e[H\e[J" }
sub position { printf "\e[%d;%dH", shift, shift }

illustrate a time-keeping device that updates every second and cycles periodically. It is designed to be simple, efficient, and not to overuse CPU resources by avoiding unnecessary system timer polling. The time displayed aligns with the system clock. Both text-based and graphical representations are supported.


The code provides an algorithm for a calendar task, formatted to fit a 132-character wide page, similar to 1969 era line printers. The entire code is written in uppercase, inspired by the preference of real programmers and the constraints of 1960s computer architecture. The code does not include Snoopy generation but outputs a placeholder instead. Due to restrictions on using certain keywords, the calendar is printed to standard error instead of standard output.


sub gcd {
    my ($n, $m) = @_;
    while($n){
        my $t = $n;
        $n = $m % $n;
        $m = $t;
    }
    return $m;
}

sub tripel {
    my $pmax  = shift;
    my $prim  = 0;
    my $count = 0;
    my $nmax = sqrt($pmax)/2;
    for( my $n=1; $n<=$nmax; $n++ ) {
        for( my $m=$n+1; (my $p = 2*$m*($m+$n)) <= $pmax; $m+=2 ) {
            next unless 1==gcd($m,$n);
            $prim++;
            $count += int $pmax/$p;
        }
    }
    printf "Max. perimeter: %d, Total: %d, Primitive: %d\n", $pmax, $count, $prim;
}

tripel 10**$_ for 1..8;

The code calculates the number of Pythagorean triples (a, b, c) where a, b, and c are positive integers, a < b < c, and a^2 + b^2 = c^2, with a perimeter (a + b + c) no larger than 100. It also determines the number of these triples that are primitive, meaning a, b, and c are co-prime. The code is also optimized to handle large values up to a maximum perimeter of 100,000,000.


Works with: Perl version 5.8.8
  use Tk;

  MainWindow->new();
  MainLoop;

  use SDL::App;
  use SDL::Event;

  $app = SDL::App->new;
  $app->loop({
    SDL_QUIT() => sub { exit 0; },
  });

  use Gtk3 '-init';

  $window = Gtk3::Window->new;
  $window->signal_connect(
    destroy => sub { Gtk3->main_quit; }
  );
  $window->show_all;
  Gtk3->main;

use strict;
use warnings;
use QtGui4;

my $app = Qt::Application(\@ARGV);
my $window = Qt::MainWindow;
$window->show;
exit $app->exec;

  use Wx;

  $window = Wx::Frame->new(undef, -1, 'title');
  $window->Show;
  Wx::SimpleApp->new->MainLoop;

"Creates an empty GUI window that can respond to close requests."


while (<>) { $cnt{lc chop}++ while length }
print "$_: ", $cnt{$_}//0, "\n" for 'a' .. 'z';

"Opens a text file, counts the frequency of each letter in a case-insensitive manner, and includes both command line and piped input. It may count all characters or only letters A to Z."


my %node = (
    data => 'say what',
    next => \%foo_node,
);
$node{next} = \%bar_node;  # mutable

define a data structure for a singly-linked list element, which includes a numeric data member and a mutable link to the next element.


use GD::Simple;

my ($width, $height) = (1000,1000); # image dimension
my $scale = 6/10; # branch scale relative to trunk
my $length = 400; # trunk size

my $img = GD::Simple->new($width,$height);
$img->fgcolor('black');
$img->penSize(1,1);

tree($width/2, $height, $length, 270);

print $img->png;

sub tree
{
        my ($x, $y, $len, $angle) = @_;

        return if $len < 1;

        $img->moveTo($x,$y);
        $img->angle($angle);
        $img->line($len);

        ($x, $y) = $img->curPos();

        tree($x, $y, $len*$scale, $angle+35);
        tree($x, $y, $len*$scale, $angle-35);
}

The code uses the GD::Simple module to generate and draw a fractal tree. It starts by drawing the trunk, then splits the end of the trunk at a certain angle to create two branches. This process is repeated at the end of each branch until a desired level of branching is achieved.


sub factors
{
        my($n) = @_;
        return grep { $n % $_ == 0 }(1 .. $n);
}
print join ' ',factors(64), "\n";

sub factors {
  my $n = shift;
  $n = -$n if $n < 0;
  my @divisors;
  for (1 .. int(sqrt($n))) {  # faster and less memory than map/grep
    push @divisors, $_ unless $n % $_;
  }
  # Return divisors including top half, without duplicating a square
  @divisors, map { $_*$_ == $n ? () : int($n/$_) } reverse @divisors;
}
print join " ", factors(64), "\n";

Library: ntheory
use ntheory qw/divisors/;
print join " ", divisors(12345678), "\n";
# Alternately something like:  fordivisors { say } 12345678;

calculate the factors of a given positive integer, excluding zero and negative integers. It also notes that every prime number has two factors: 1 and itself.


#/usr/bin/perl -w
use strict ;

die "Call : perl columnaligner.pl <inputfile> <printorientation>!\n" unless
   @ARGV == 2 ; #$ARGV[ 0 ] contains example file , $ARGV[1] any of 'left' , 'right' or 'center'
die "last argument must be one of center, left or right!\n" unless
   $ARGV[ 1 ] =~ /center|left|right/ ;
sub printLines( $$$ ) ;
open INFILE , "<" , "$ARGV[ 0 ]" or die "Can't open $ARGV[ 0 ]!\n" ;
my @lines = <INFILE> ;
close INFILE ;
chomp @lines ;
my @fieldwidths = map length, split /\$/ , $lines[ 0 ] ;
foreach my $i ( 1..$#lines ) {
   my @words = split /\$/ , $lines[ $i ] ;
   foreach my $j ( 0..$#words ) {
      if ( $j <= $#fieldwidths ) {
         if ( length $words[ $j ] > $fieldwidths[ $j ] ) {
               $fieldwidths[ $j ] = length $words[ $j ] ;
         }
      }
      else {
         push @fieldwidths, length $words[ $j ] ;
      }
   }
}
printLine( $_ , $ARGV[ 1 ] , \@fieldwidths ) foreach @lines ;
##################################################################    ####
sub printLine {
   my $line = shift ;
   my $orientation = shift ;
   my $widthref = shift ;
   my @words = split /\$/, $line ;
   foreach my $k ( 0..$#words ) {
      my $printwidth = $widthref->[ $k ] + 1 ;
      if ( $orientation eq 'center' ) {
         $printwidth++ ;
      }
      if ( $orientation eq 'left' ) {
         print $words[ $k ] ;
         print " " x ( $printwidth - length $words[ $k ] ) ;
      }
      elsif ( $orientation eq 'right' ) {
         print " " x ( $printwidth - length $words[ $k ] ) ;
         print $words[ $k ] ;
      }
      elsif ( $orientation eq 'center' ) {
         my $left = int( ( $printwidth - length $words[ $k ] )     / 2 ) ;
         my $right = $printwidth - length( $words[ $k ] ) - $left      ;
         print " " x $left ;
         print $words[ $k ] ;
         print " " x $right ;
      }
   }
   print "\n" ;
}

use List::Util qw(max);

sub columns {
    my @lines = map [split /\$/] => split /\n/ => shift;
    my $pos = {qw/left 0 center 1 right 2/}->{+shift};
    for my $col (0 .. max map {$#$_} @lines) {
        my $max = max my @widths = map {length $_->[$col]} @lines;
        for my $row (0 .. $#lines) {
            my @pad = map {' ' x $_, ' ' x ($_ + 0.5)} ($max - $widths[$row]) / 2;
            for ($lines[$row][$col])
                {$_ = join '' => @pad[0 .. $pos-1], $_, @pad[$pos .. $#pad]}
        }
    }
    join '' => map {"@$_\n"} @lines
}

print columns <<'END', $_ for qw(left right center);
Given$a$text$file$of$many$lines,$where$fields$within$a$line$
are$delineated$by$a$single$'dollar'$character,$write$a$program
that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
column$are$separated$by$at$least$one$space.
Further,$allow$for$each$word$in$a$column$to$be$either$left$
justified,$right$justified,$or$center$justified$within$its$column.
END

The code reads a text file where each line's fields are separated by a dollar sign. It aligns each column by ensuring there is at least one space between words in each column. The code also allows for words in a column to be left, right, or center justified. The minimum space between columns is computed from the text, not hard-coded. The output is viewed in a mono-spaced font on a plain text editor or basic terminal.


represent a cuboid with dimensions 2x3x4, drawn either graphically or in ASCII art, with three visible faces, and can be either static or rotational.


use Net::LDAP;

my $ldap = Net::LDAP->new('ldap://ldap.example.com') or die $@;
my $mesg = $ldap->bind( $bind_dn, password => $bind_pass );

establish a connection to an Active Directory or Lightweight Directory Access Protocol (LDAP) server using LDAP modules.


sub rot13 {
  shift =~ tr/A-Za-z/N-ZA-Mn-za-m/r;
}

print rot13($_) while (<>);

NOWHERE Abjurer

ABJURER Nowhere

perl -pe 'tr/A-Za-z/N-ZA-Mn-za-m/'

implement a rot-13 function that encodes every line of input from a file or standard input. The function replaces every ASCII letter with the letter that is 13 characters away in the alphabet, wrapping from z to a as needed. It should work on both upper and lower case letters, preserve case, and pass all non-alphabetic characters without alteration. This function can be optionally wrapped in a utility program.


sort an array of composite structures, specifically name-value pairs, by the key 'name' using a custom comparator.


demonstrate how to use nested "for" loops to print a specific pattern. The number of iterations of the inner loop is controlled by the outer loop. If the constraint of using two loops is removed, the code becomes simpler.


# using => key does not need to be quoted unless it contains special chars
my %hash = (
  key1 => 'val1',
  'key-2' => 2,
  three => -238.83,
  4 => 'val3',
);

# using , both key and value need to be quoted if containing something non-numeric in nature
my %hash = (
  'key1', 'val1',
  'key-2', 2,
  'three', -238.83,
  4, 'val3',
);

print $hash{key1};

$hash{key1} = 'val1';

@hash{'key1', 'three'} = ('val1', -238.83);

my $hashref = {
 key1 => 'val1',
  'key-2' => 2,
  three => -238.83,
  4 => 'val3',
}

print $hashref->{key1};

$hashref->{key1} = 'val1';

@{$hashref}{('key1', 'three')} = ('val1', -238.83);

create an associative array, also known as a dictionary, map, or hash. The keys are primarily strings, but integers can also be used. Special care is needed for floating point keys to avoid round-off errors. Modules like Tie::RefHash can be used to create keys of other types.


The code implements two historic random number generators: the rand() function from BSD libc and the rand() function from the Microsoft C Runtime (MSCVRT.DLL). These generators use the linear congruential generator formula with specific constants. The generators produce a sequence of integers, starting from a seed value, that is not cryptographically secure but can be used for simple tasks. The BSD generator outputs numbers in the range 0 to 2147483647, while the Microsoft generator outputs numbers in the range 0 to 32767.


my @l  = ($A, $B);
push @l, $C, splice @l, 1;

sub insert_after {
  # first argument: node to insert after
  # second argument: node to insert
  $_[1]{next} = $_[0]{next};
  $_[0]{next} = $_[1];
}

my %B = (
    data => 3,
    next => undef, # not a circular list
);
my %A = (
    data => 1,
    next => \%B,
);
my %C = (
    data => 2,
);
insert_after \%A, \%C;

 insert_after \%A, { data => 2 };

sub insert_after {
  my $node = $_[0];
  my $next = $node->{next};
  shift;
  while (defined $_[0]) {
    $node->{next} = $_[0];
    $node = $node->{next};
    shift;
  }
  $node->{next} = $next;
}

my %list = ( data => 'A' );
insert_after \%list, { data => 'B' }, { data => 'C' };

my $list2;

# create a new list ('A'. 'B', 'C') and store it in $list2
insert_after $list2 = { data => 'A' }, { data => 'B' }, { data => 'C' };

# append two new nodes ('D', 'E') after the first element
insert_after $list2, { data => 'A2' }, { data => 'A3' };

# append new nodes ('A2a', 'A2b') after the second element (which now is 'A2')
insert_after $list2->{next}, { data => 'A2a' }, { data => 'A2b' };

define a method for inserting an element into a singly-linked list after a specified element. The method is used to insert element C into a list consisting of elements A and B, after element A. The code also includes notes on the use of arrays versus linked lists, the use of references for translation, and the simplification of list handling through the use of variables containing references.


use strict;

sub halve { int((shift) / 2); }
sub double { (shift) * 2; }
sub iseven { ((shift) & 1) == 0; }

sub ethiopicmult
{
    my ($plier, $plicand, $tutor) = @_;
    print "ethiopic multiplication of $plier and $plicand\n" if $tutor;
    my $r = 0;
    while ($plier >= 1)
    {
	$r += $plicand unless iseven($plier);
	if ($tutor) {
	    print "$plier, $plicand ", (iseven($plier) ? " struck" : " kept"), "\n";
	}
	$plier = halve($plier);
	$plicand = double($plicand);
    }
    return $r;
}

print ethiopicmult(17,34, 1), "\n";

The code defines three functions for halving an integer, doubling an integer, and checking if an integer is even. These functions are used to implement Ethiopian multiplication, a method of multiplying integers using addition, doubling, and halving. The multiplication process involves creating a table, discarding rows with even numbers in the left column, and summing the remaining values in the right column.


# Fischer-Krause ordered permutation generator
# http://faq.perl.org/perlfaq4.html#How_do_I_permute_N_e
sub permute :prototype(&@) {
		my $code = shift;
		my @idx = 0..$#_;
		while ( $code->(@_[@idx]) ) {
			my $p = $#idx;
			--$p while $idx[$p-1] > $idx[$p];
			my $q = $p or return;
			push @idx, reverse splice @idx, $p;
			++$q while $idx[$p-1] > $idx[$q];
			@idx[$p-1,$q]=@idx[$q,$p-1];
		}
	}

@formats = (
	'((%d %s %d) %s %d) %s %d',
	'(%d %s (%d %s %d)) %s %d',
	'(%d %s %d) %s (%d %s %d)',
	'%d %s ((%d %s %d) %s %d)',
	'%d %s (%d %s (%d %s %d))',
	);

# generate all possible combinations of operators
@op = qw( + - * / );
@operators = map{ $a=$_; map{ $b=$_; map{ "$a $b $_" }@op }@op }@op;

while(1)
{
	print "Enter four integers or 'q' to exit: ";
	chomp($ent = <>);
	last if $ent eq 'q';

	if($ent !~ /^[1-9] [1-9] [1-9] [1-9]$/){ print "invalid input\n"; next }

	@n = split / /,$ent;
	permute { push @numbers,join ' ',@_ }@n;

	for $format (@formats)
	{
		for(@numbers)
		{
			@n = split;
			for(@operators)
			{
				@o = split;
				$str = sprintf $format,$n[0],$o[0],$n[1],$o[1],$n[2],$o[2],$n[3];
				$r = eval($str);
				print "$str\n" if $r == 24;
			}
		}
	}
}

The code takes four digits as input, either from the user or generated randomly, and computes all possible arithmetic expressions based on the rules of the 24 game. It also displays examples of the solutions it generates. The permute function used in the code is sourced from an external link.


sub factorial
{
  my $n = shift;
  my $result = 1;
  for (my $i = 1; $i <= $n; ++$i)
  {
    $result *= $i;
  };
  $result;
}

# using a .. range
sub factorial {
    my $r = 1;
    $r *= $_ for 1..shift;
    $r;
}
sub factorial
{
  my $n = shift;
  ($n == 0)? 1 : $n*factorial($n-1);
}
use List::Util qw(reduce);
sub factorial
{
  my $n = shift;
  reduce { $a * $b } 1, 1 .. $n
}

Library: ntheory
use ntheory qw/factorial/;
# factorial returns a UV (native unsigned int) or Math::BigInt depending on size
say length(  factorial(10000)  );
use bigint;
say length(  10000->bfac  );
use Math::GMP;
say length(  Math::GMP->new(10000)->bfac  );
use Math::Pari qw/ifact/;
say length(  ifact(10000)  );

"Implements a function to calculate the factorial of a given number, either iteratively or recursively. The function may optionally handle errors for negative input values. The output is the product of the sequence from the input number down to 1."


use Data::Random qw(rand_set);
use List::MoreUtils qw(uniq);

my $size = 4;
my $chosen = join "", rand_set set => ["1".."9"], size => $size;

print "I've chosen a number from $size unique digits from 1 to 9; you need
to input $size unique digits to guess my number\n";

for ( my $guesses = 1; ; $guesses++ ) {
    my $guess;
    while (1) {
        print "\nNext guess [$guesses]: ";
        $guess = <STDIN>;
        chomp $guess;
        checkguess($guess) and last;
        print "$size digits, no repetition, no 0... retry\n";
    }
    if ( $guess eq $chosen ) {
        print "You did it in $guesses attempts!\n";
        last;
    }
    my $bulls = 0;
    my $cows = 0;
    for my $i (0 .. $size-1) {
        if ( substr($guess, $i, 1) eq substr($chosen, $i, 1) ) {
            $bulls++;
        } elsif ( index($chosen, substr($guess, $i, 1)) >= 0 ) {
            $cows++;
        }
    }
    print "$cows cows, $bulls bulls\n";
}

sub checkguess
{
    my $g = shift;
    return uniq(split //, $g) == $size && $g =~ /^[1-9]{$size}$/;
}

generate a unique four-digit number, accept and validate user guesses, calculate and print scores based on matching digits and their positions, and end the program when the user guess matches the generated number.


generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5.


sub dotprod
{
        my($vec_a, $vec_b) = @_;
        die "they must have the same size\n" unless @$vec_a == @$vec_b;
        my $sum = 0;
        $sum += $vec_a->[$_] * $vec_b->[$_] for 0..$#$vec_a;
        return $sum;
}

my @vec_a = (1,3,-5);
my @vec_b = (4,-2,-1);

print dotprod(\@vec_a,\@vec_b), "\n"; # 3

Implement a function to calculate the dot product of two vectors of arbitrary length. The function multiplies corresponding elements from each vector and sums the products. The vectors must be of the same length. Example vectors used are [1, 3, -5] and [4, -2, -1].


open FH, "< $filename" or die "can't open file: $!";
while (my $line = <FH>) {
    chomp $line; # removes trailing newline
    # process $line
}
close FH or die "can't close file: $!";

@lines = <FH>;

while (<>) {
    # $_ contains a line
}

$ seq 5 | perl -pe '$_ = "Hello $_"'
Hello 1
Hello 2
Hello 3
Hello 4
Hello 5
$ seq 5 | perl -ne 'print "Hello $_"'
Hello 1
Hello 2
Hello 3
Hello 4
Hello 5

The code reads data from a text stream either word-by-word or line-by-line until there is no more data. It uses the angle brackets operator to read a line at a time or all lines at once, depending on the context. It can also handle files entered as command line arguments or standard input. If invoked with the -p or -n option, it executes the loop once per input line, storing the line in $_. The -p option also prints $_ at the end of each iteration.


Library: XML::SimpleSimple
use XML::Simple;
print XMLout( { root => { element => "Some text here" } }, NoAttr => 1, RootName => "" );

<root>
  <element>Some text here</element>
</root>

Library: XML::DOM::BagOfTricksDOM::BagOfTricks
use XML::DOM::BagOfTricks qw(createDocument createTextElement);

my ($doc, $root) = createDocument('root');
$root->appendChild(
    createTextElement($doc, 'element', 'Some text here')
);
print $doc->toString;

<root><element>Some text here</element></root>

Library: LibXML
use XML::LibXML;

$xml = XML::LibXML::Document->new('1.0');
$node = $xml->createElement('root');
$xml->setDocumentElement($node);
$node2 = $xml->createElement('element');
$text = $xml->createTextNode('Some text here');
$node2->addChild($text);
$node->appendWellBalancedChunk('text');
$node->addChild($node2);

print $xml->toString;

<?xml version="1.0"?>
<root>text<element>Some text here</element></root>

create a simple DOM and serialize it into a specific XML format.


Simple localtime use in scalar context.print scalar localtime, "\n";

the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. The time is retrieved either by a system command or a built-in language function. It is related to the task of date formatting and retrieving system time.


use List::Util qw(sum);
use POSIX qw(strtol);

sub zip :prototype(&\@\@) {
  my $f = shift;
  my @a = @{shift()};
  my @b = @{shift()};
  my @result;
  push(@result, $f->(shift @a, shift @b)) while @a && @b;
  return @result;
}

my @weights = (1, 3, 1, 7, 3, 9);
sub sedan :prototype($) {
  my $s = shift;
  $s =~ /[AEIOU]/ and die "No vowels";
  my @vs = map {(strtol $_, 36)[0]} split //, $s;
  my $checksum = sum (zip {$_[0] * $_[1]} @vs, @weights);
  my $check_digit = (10 - $checksum % 10) % 10;
  return $s . $check_digit;
}

while (<>) {
    chomp;
    print sedol($_), "\n";
}

The code takes a list of 6-digit SEDOLs as input, calculates and appends the checksum digit to each SEDOL, and outputs the new SEDOLs. It also validates the input to ensure it contains only valid characters for a SEDOL string. The code reads from standard input.


use strict;
use warnings;

my $x = my $y = 255;
$x |= 1; # must be odd
my $depth = 255;

my $light = Vector->new(rand, rand, rand)->normalized;

print "P2\n$x $y\n$depth\n";

my ($r, $ambient) = (($x - 1)/2, 0);
my ($r2) = $r ** 2;
{
    for my $x (-$r .. $r) {
	my $x2 = $x**2;
	for my $y (-$r .. $r) {
	    my $y2 = $y**2;
	    my $pixel = 0;
	    if ($x2 + $y2 < $r2) {
		my $v = Vector->new($x, $y, sqrt($r2 - $x2 - $y2))->normalized;
		my $I = $light . $v + $ambient;
		$I = $I < 0 ? 0 : $I > 1 ? 1 : $I;
		$pixel = int($I * $depth);
	    }
	    print $pixel;
	    print $y == $r ? "\n" : " ";
	}
    }
}

package Vector {
    sub new {
	my $class = shift;
	bless ref($_[0]) eq 'Array' ? $_[0] : [ @_ ], $class;
    }
    sub normalized {
	my $this = shift;
	my $norm = sqrt($this . $this);
	ref($this)->new( map $_/$norm, @$this );
    }
    use overload q{.} => sub {
	my ($a, $b) = @_;
	my $sum = 0;
	for (0 .. @$a - 1) {
	    $sum += $a->[$_] * $b->[$_]
	}
	return $sum;
    },
    q{""} => sub { sprintf "Vector:[%s]", join ' ', @{shift()} };
}

generate a graphical or ASCII art representation of a sphere, with either static or rotational projection. The output is a PGM image similar to the Raku solution.


The code is a function that takes an integer input (greater than or equal to zero) and returns a string of the number followed by an apostrophe and its corresponding ordinal suffix. The function is demonstrated with integer ranges 0..25, 250..265, and 1000..1025. It requires Perl 5.10 or newer for the Defined OR operator, or alternatively, a library can be used.


sub stripchars {
    my ($s, $chars) = @_;
    $s =~ s/[$chars]//g;
    return $s;
}

print stripchars("She was a soul stripper. She took my heart!", "aei"), "\n";

"Function to strip specified characters from a given string. The function takes two arguments - the original string and a string of characters to be stripped. The function returns the original string with all instances of the specified characters removed. Special characters may need to be escaped. The function uses the tr/// operator for efficiency when the set of characters to strip is known at compile time."


#!bin/usr/perl
use 5.020;
use strict;
use warnings;

#Get a max number from the user
say("Please enter the maximum possible multiple. ");
my $max = <STDIN>;

#Get the factors from the user
my @factors = ();
my $buffer;
say("Now enter the first factor and its associated word. Ex: 3 Fizz ");
chomp($buffer = <STDIN>);
push @factors, $buffer;
say("Now enter the second factor and its associated word. Ex: 5 Buzz ");
chomp($buffer = <STDIN>);
push @factors, $buffer;
say("Now enter the third factor and its associated word. Ex: 7 Baxx ");
chomp($buffer = <STDIN>);
push @factors, $buffer;

#Counting from 1 to max
for(my $i = 1; $i <= $max; $i++)
{
    #Create a secondary buffer as well as set the original buffer to the current index
    my $oBuffer;
    $buffer = $i;
    #Run through each element in our array
    foreach my $element (@factors)
    {
        #Look for white space
        $element =~ /\s/;
        #If the int is a factor of max, append it to oBuffer as a string to be printed
        if($i % substr($element, 0, @-) == 0)
        {
            $oBuffer = $oBuffer . substr($element, @+ + 1, length($element));
            #This is essentially setting a flag saying that at least one element is a factor
            $buffer = "";
        }
    }
    #If there are any factors for that number, print their words. If not, print the number.
    if(length($buffer) > 0)
    {
        print($buffer . "\n");
    }
    else
    {
        print($oBuffer . "\n");
    }
}

implement a generalized version of FizzBuzz that takes a maximum number and a list of factor-word pairs as inputs from the user. The code prints numbers from 1 to the maximum number, replacing multiples of each factor with the corresponding word. For numbers that are multiples of multiple factors, the associated words are printed in ascending order of their factors.


use strict;
use warnings;
use feature ':all';

# explicit concatentation
$_ = 'bar';
$_ = 'Foo' . $_;
say;

# lvalue substr
$_ = 'bar';
substr $_, 0, 0, 'Foo';
say;

# interpolation as concatenation
# (NOT safe if concatenate sigils)
$_ = 'bar';
$_ = "Foo$_";
say;

Creates a string variable with a specific text value, prepends another string literal to it, and displays the content of the variable. If possible, the operation is performed without referring to the variable twice in one expression.


use SVG;
use List::Util qw(max min);

use constant pi => 2 * atan2(1, 0);

# Compute the curve with a Lindemayer-system
my %rules = (
    X => 'X+YF+',
    Y => '-FX-Y'
);
my $dragon = 'FX';
$dragon =~ s/([XY])/$rules{$1}/eg for 1..10;

# Draw the curve in SVG
($x, $y) = (0, 0);
$theta   = 0;
$r       = 6;

for (split //, $dragon) {
    if (/F/) {
        push @X, sprintf "%.0f", $x;
        push @Y, sprintf "%.0f", $y;
        $x += $r * cos($theta);
        $y += $r * sin($theta);
    }
    elsif (/\+/) { $theta += pi/2; }
    elsif (/\-/) { $theta -= pi/2; }
}

$xrng =  max(@X) - min(@X);
$yrng =  max(@Y) - min(@Y);
$xt   = -min(@X)+10;
$yt   = -min(@Y)+10;
$svg = SVG->new(width=>$xrng+20, height=>$yrng+20);
$points = $svg->get_path(x=>\@X, y=>\@Y, -type=>'polyline');
$svg->rect(width=>"100%", height=>"100%", style=>{'fill'=>'black'});
$svg->polyline(%$points, style=>{'stroke'=>'orange', 'stroke-width'=>1}, transform=>"translate($xt,$yt)");

open  $fh, '>', 'dragon_curve.svg';
print $fh  $svg->xmlify(-namespace=>'svg');
close $fh;

The code generates a dragon curve fractal, either displaying it directly or writing it to an image file. It uses various algorithms such as recursive, successive approximation, iterative, and Lindenmayer system to create the fractal. The code also includes functionality to calculate absolute direction, X,Y coordinates, and to test whether a given point or segment is on the curve. It also allows for variations and can draw other curves defined by L-systems. The output can be limited to a desired length or sub-section.


my $number = 1 + int rand 10;
do { print "Guess a number between 1 and 10: " } until <> == $number;
print "You got it!\n";

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


generate a sequence of all lower case ASCII characters from a to z. This is done in a reliable coding style suitable for large programs, using strong typing if available. The code avoids manual enumeration of characters to prevent bugs. It also demonstrates how to access a similar sequence from the standard library if it exists.


generate a sequence of binary digits for a given non-negative integer. The output displays only the binary digits of each number, followed by a newline, without any whitespace, radix, sign markers, or leading zeros. The conversion can be achieved using built-in radix functions or a user-defined function.


"Merge and aggregate two .csv datasets, grouping by patient id and last name. The output dataset should include the maximum visit date, and the sum and average of the scores per patient. The data can be loaded from the .csv files or hard-coded, and the resulting dataset can be stored in-memory or outputted to the screen or file."


Library: Gtk3
use Gtk3 '-init';

my $window = Gtk3::Window->new();
$window->set_default_size(320, 240);
$window->set_border_width(10);
$window->set_title("Draw a Pixel");
$window->set_app_paintable(TRUE);

my $da = Gtk3::DrawingArea->new();
$da->signal_connect('draw' => \&draw_in_drawingarea);
$window->add($da);
$window->show_all();

Gtk3->main;

sub draw_in_drawingarea
{
  my ($widget, $cr, $data) = @_;
  $cr->set_source_rgb(1, 0, 0);
  $cr->set_line_width(1);
  $cr->rectangle( 100, 100, 1, 1);
  $cr->stroke;
}

"Creates a 320x240 window and draws a single red pixel at position (100, 100)."


my $fullname;
my $favouritefruit;
my $needspeeling;
my $seedsremoved;
my @otherfamily;

# configuration file definition.  See read_conf_file below for explanation.
my $conf_definition = {
    'fullname'          => [ 'string', \$fullname ],
    'favouritefruit'    => [ 'string', \$favouritefruit ],
    'needspeeling'      => [ 'boolean', \$needspeeling ],
    'seedsremoved'      => [ 'boolean', \$seedsremoved ],
    'otherfamily'       => [ 'array', \@otherfamily ],
};

my $arg = shift;               # take the configuration file name from the command line
                               # (or first subroutine argument if this were in a sub)
my $file;                      # this is going to be a file handle reference
open $file, $arg or die "Can't open configuration file '$arg': $!";

read_conf_file($file, $conf_definition);

print "fullname = $fullname\n";
print "favouritefruit = $favouritefruit\n";
print "needspeeling = ", ($needspeeling ? 'true' : 'false'), "\n";
print "seedsremoved = ", ($seedsremoved ? 'true' : 'false'), "\n";
for (my $i = 0; $i < @otherfamily; ++$i) {
    print "otherfamily(", $i + 1, ") = ", $otherfamily[$i], "\n";
}

# read_conf_file:  Given a file handle opened for reading and a configuration definition,
# read the file.
# If the configuration file doesn't match the definition, raise an exception with "die".
# The configuration definition is (a reference to) an associative array
# where the keys are the configuration variable names in all lower case
# and the values are references to arrays.
# The first element of each of these arrays is the expected type:  'boolean', 'string', or 'array';
# the second element is a reference to the variable that should be assigned the data.
sub read_conf_file {
    my ($fh, $def) = @_;        # copy parameters

    local $_;                   # avoid interfering with use of $_ in main program
    while (<$fh>) {             # read a line from $fh into $_ until end of file
        next if /^#/;           # skip "#" comments
        next if /^;/;           # skip ";" comments
        next if /^$/;           # skip blank lines
        chomp;                  # strip final newline

        $_ =~ /^\s*(\w+)\s*(.*)$/i or die "Syntax error";
        my $key = $1;
        my $rest = $2;
        $key =~ tr/[A-Z]/[a-z]/; # convert keyword to lower case

        if (!exists $def->{$key}) {
            die "Unknown keyword: '$key'";
        }

        if ($def->{$key}[0] eq 'boolean') {
            if ($rest) {
                die "Syntax error:  extra data following boolean '$key'";
            }
            ${$def->{$key}[1]} = 1;
            next;                # done with this line, go back to "while"
        }

        $rest =~ s/\s*$//;       # drop trailing whitespace
        $rest =~ s/^=\s*//;      # drop equals sign if present

        if ($def->{$key}[0] eq 'string') {
            ${$def->{$key}[1]} = $rest;
        } elsif ($def->{$key}[0] eq 'array') {
            @{$def->{$key}[1]} = split /\s*,\s*/, $rest;
        } else {
            die "Internal error (unknown type in configuration definition)";
        }
    }
}

The code reads a configuration file in standard format, ignores lines starting with a hash or semicolon, and blank lines. It sets variables based on the configuration entries, including fullname, favouritefruit, needspeeling, and seedsremoved. It also handles options with multiple parameters, storing them in an array. The code checks the configuration file syntax and contents, raising exceptions if there are errors.


Library: ntheory
use ntheory qw/Pi/;

sub asin { my $x = shift; atan2($x, sqrt(1-$x*$x)); }

sub surfacedist {
  my($lat1, $lon1, $lat2, $lon2) = @_;
  my $radius = 6372.8;
  my $radians = Pi() / 180;;
  my $dlat = ($lat2 - $lat1) * $radians;
  my $dlon = ($lon2 - $lon1) * $radians;
  $lat1 *= $radians;
  $lat2 *= $radians;
  my $a = sin($dlat/2)**2 + cos($lat1) * cos($lat2) * sin($dlon/2)**2;
  my $c = 2 * asin(sqrt($a));
  return $radius * $c;
}
my @BNA = (36.12, -86.67);
my @LAX = (33.94, -118.4);
printf "Distance: %.3f km\n", surfacedist(@BNA, @LAX);

implement the Haversine formula to calculate the great-circle distance between two points on a sphere using their longitudes and latitudes. The points in this case are Nashville International Airport (BNA) and Los Angeles International Airport (LAX). The code uses either the authalic radius (6371.0 km) or the average great-circle radius (6372.8 km) for calculations, with the latter being recommended. The code also takes into account the recommendations from the International Union of Geodesy and Geophysics for real applications. The Perl core distribution's Math::Trig is used for the great circle distance calculation.


Library: HTTP/Tiny
Works with: Perl version 5.14
Works with: Perl/HTTP/Tiny

use strict; use warnings;
require 5.014; # check HTTP::Tiny part of core
use HTTP::Tiny;

print( HTTP::Tiny->new()->get( 'http://rosettacode.org')->{content} );

Works with: Perl/LWP

use LWP::Simple qw/get $ua/;
$ua->agent(undef) ; # cloudflare blocks default LWP agent
print( get("http://www.rosettacode.org") );

use strict;
use LWP::UserAgent;

my $url = 'http://www.rosettacode.org';
my $response = LWP::UserAgent->new->get( $url );

$response->is_success or die "Failed to GET '$url': ", $response->status_line;

print $response->as_string

Accesses and prints the content of a URL using HTTP::Tiny, a library added to the core libraries in Perl/5.14, similar to the LWP sample but with additional error-checking. This does not handle HTTPS requests.


The code implements the Luhn test for validating credit card numbers. It first reverses the order of the digits in the number. Then, it calculates two partial sums, s1 and s2. S1 is the sum of the odd digits in the reversed number. S2 is calculated by doubling each even digit, summing the digits if the result is greater than nine, and then summing these results. If the sum of s1 and s2 ends in zero, the number is a valid credit card number. The code validates the numbers 49927398716, 49927398717, 1234567812345678, and 1234567812345670 using this method.


my @prisoner = 0 .. 40;
my $k = 3;
until (@prisoner == 1) {
    push @prisoner, shift @prisoner for 1 .. $k-1;
    shift @prisoner;
}

print "Prisoner @prisoner survived.\n"

- Determine the final survivor in the Josephus problem given any number of prisoners (n) and a step count (k).
- Calculate the position of any prisoner in the killing sequence.
- Provide an option to save a certain number of prisoners (m).
- The numbering of prisoners can start from either 0 or 1.
- The complexity of the solution is O(kn) for the complete killing sequence and O(m) for finding the m-th prisoner to die.


The code takes a string or a character as input and repeats it a specified number of times. For example, if the input is "ha" and 5, the output will be "hahahahaha". Similarly, if the input is "*" and 5, the output will be "*****".


Works with: Perl version 5.8.8

$string = "I am a string";
if ($string =~ /string$/) {
   print "Ends with 'string'\n";
}

if ($string !~ /^You/) {
   print "Does not start with 'You'\n";
}

$string = "I am a string";
$string =~ s/ a / another /; # makes "I am a string" into "I am another string"
print $string;

$string = "I am a string";
$string2 = $string =~ s/ a / another /r; # $string2 == "I am another string", $string is unaltered
print $string2;

$string = "I am a string";
if ($string =~ s/\bam\b/was/) { # \b is a word border
   print "I was able to find and replace 'am' with 'was'\n";
}

# add the following just after the last / for additional control
# g = globally (match as many as possible)
# i = case-insensitive
# s = treat all of $string as a single line (in case you have line breaks in the content)
# m = multi-line (the expression is run on each line individually)

$string =~ s/i/u/ig; # would change "I am a string" into "u am a strung"

$_ = "I like banana milkshake.";
if (/banana/) {          # The regular expression binding operator is omitted
  print "Match found\n";
}

The code matches a string against a regular expression and substitutes part of the string using the regular expression. It returns a new substituted string without altering the original string in Perl 5.14+. The code also omits the regular expression binding operators when matches are made against the topic variable.


Works with: Perl version 5.x
my $a = <>;
my $b = <>;

print
    "sum:              ", $a + $b, "\n",
    "difference:       ", $a - $b, "\n",
    "product:          ", $a * $b, "\n",
    "integer quotient: ", int($a / $b), "\n",
    "remainder:        ", $a % $b, "\n",
    "exponent:         ", $a ** $b, "\n"
    ;

take two integers as input from the user and display their sum, difference, product, integer quotient, remainder, and exponentiation. The code also indicates the rounding direction for the quotient and the sign of the remainder. It does not include error handling. A bonus feature is the inclusion of the `divmod` operator example.


sub countSubstring {
  my $str = shift;
  my $sub = quotemeta(shift);
  my $count = () = $str =~ /$sub/g;
  return $count;
#  or return scalar( () = $str =~ /$sub/g );
}

print countSubstring("the three truths","th"), "\n"; # prints "3"
print countSubstring("ababababab","abab"), "\n"; # prints "2"

The code defines a function to count the number of non-overlapping occurrences of a given substring within a larger string. The function takes two arguments: the main string and the substring to search for. It returns an integer representing the count of non-overlapping occurrences. The function prioritizes the highest number of non-overlapping matches, typically matching from left-to-right or right-to-left.


sub hanoi {
    my ($n, $from, $to, $via) = (@_, 1, 2, 3);

    if ($n == 1) {
        print "Move disk from pole $from to pole $to.\n";
    } else {
        hanoi($n - 1, $from, $via, $to);
        hanoi(1, $from, $to, $via);
        hanoi($n - 1, $via, $to, $from);
    };
};

"Implement a recursive solution to solve the Towers of Hanoi problem."


sub binomial {
    use bigint;
    my ($r, $n, $k) = (1, @_);
    for (1 .. $k) { $r *= $n--; $r /= $_ }
    $r;
}

print binomial(5, 3);

The code calculates any binomial coefficient using the provided formula. It is specifically designed to output the binomial coefficient of 5 choose 3, which is 10. It also includes tasks for generating combinations and permutations with and without replacement. The code uses the bigint module's binomial method for better performance, especially with large inputs, and the Math::Pari module, which requires large amounts of added stack space for large arguments.


implement the Shell sort algorithm to sort an array of elements. This algorithm, invented by Donald Shell, uses a diminishing increment sort and interleaved insertion sorts based on an increment sequence. The increment size reduces after each pass until it reaches 1, turning the sort into a basic insertion sort. The data is almost sorted at this point, providing the best case for insertion sort. The increment sequence can vary but should always end in 1. Sequences with a geometric increment ratio of about 2.2 have been found to work well.


Library: Imlib2

#! /usr/bin/perl

use strict;
use Image::Imlib2;

sub tograyscale
{
    my $img = shift;
    my $gimg = Image::Imlib2->new($img->width, $img->height);
    for ( my $x = 0; $x < $gimg->width; $x++ ) {
	for ( my $y = 0; $y < $gimg->height; $y++ ) {
	    my ( $r, $g, $b, $a ) = $img->query_pixel($x, $y);
	    my $gray = int(0.2126 * $r + 0.7152 * $g + 0.0722 * $b);
	    # discard alpha info...
	    $gimg->set_color($gray, $gray, $gray, 255);
	    $gimg->draw_point($x, $y);
	}
    }
    return $gimg;
}

my $animage = Image::Imlib2->load("Lenna100.jpg");
my $gscale = tograyscale($animage);
$gscale->set_quality(80);
$gscale->save("Lennagray.jpg");

exit 0;

extend the data storage type to support grayscale images. They define two operations to convert a color image to grayscale and vice versa using the CIE recommended formula for luminance. The codes ensure that rounding errors in floating-point arithmetic do not cause run-time issues or distort results when storing calculated luminance as an unsigned integer. The codes use Imlib2 to convert RGB images to grayscale-like images.


use Tk;
use Time::HiRes qw(sleep);

my $msg    = 'Hello World! ';
my $first  = '.+';
my $second = '.';

my $mw = Tk::MainWindow->new(-title => 'Animated side-scroller',-bg=>"white");
$mw->geometry ("400x150+0+0");

$mw->optionAdd('*Label.font', 'Courier 24 bold' );

my $scroller = $mw->Label(-text => "$msg")->grid(-row=>0,-column=>0);
$mw->bind('all'=> '<Key-Escape>' => sub {exit;});
$mw->bind("<Button>" => sub { ($second,$first) = ($first,$second) });

$scroller->after(1, \&display );
MainLoop;

sub display {
    while () {
        sleep 0.25;
        $msg =~ s/($first)($second)/$2$1/;
        $scroller->configure(-text=>"$msg");
        $mw->update();
    }
}

Create a GUI animation where the string "Hello World! " appears to rotate right by periodically moving the last letter to the front. The direction of rotation reverses when the user clicks on the text.


my $val = 0;
do {
   $val++;
   print "$val\n";
} while ($val % 6);

my $val = 0;
do {
   $val++;
   print "$val\n";
} until ($val % 6 == 0);

Initializes a value at 0, then enters a loop that increments the value by 1 and prints it each iteration. The loop continues until the value modulo 6 equals 0. The loop is guaranteed to execute at least once.


Works with: Perl version 5.8

use utf8; # so we can use literal characters like ☺ in source
use Encode qw(encode);

print length encode 'UTF-8', "Hello, world! ☺";
# 17. The last character takes 3 bytes, the others 1 byte each.

print length encode 'UTF-16', "Hello, world! ☺";
# 32. 2 bytes for the BOM, then 15 byte pairs for each character.
Works with: Perl version 5.X
my $length = length "Hello, world!";

Works with: Perl version 5.12
use v5.12;
my $string = "\x{1112}\x{1161}\x{11ab}\x{1100}\x{1173}\x{11af}";  # 한글
my $len;
$len++ while ($string =~ /\X/g);
printf "Grapheme length: %d\n", $len;

The code calculates the character and byte length of a string, considering UTF-8 and UTF-16 encodings. It correctly handles non-BMP code points and provides actual character counts in code points, not in code unit counts. It also provides the string length in graphemes if the language supports it. For Perl strings, it measures the byte length by converting to a binary representation. It also matches an extended grapheme cluster in Perl 5.12 and above.